package Browser::LibModule;
my $RCSRevKey = '$Revision: 1.5 $';
$RCSRevKey =~ /Revision: (.*?) /;
$VERSION=0.67;
use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
push @ISA, qw( Tk Exporter DB );

@EXPORT_OK=qw($VERSION new retrieve readlib BaseName DESTROY);

require Exporter;
require Carp;
use File::Basename;
use Browser::LibModuleSymbol;
use Browser::LibSymbolRef;

my @modulepathnames;
my @libdirectories;

=head1 Browser::LibModule.pm - Perl Library Support for Tk::Browser.pm

=head1 SYNOPSIS

  use Browser::LibModule;
  use Browser::LibModuleSymbol;
  use Browser::LibSymbolRef;

=head1 DESCRIPTION

Browser::LibModule provides a Tk::Browser(3) with hierarchical object
references to Perl library modules, including package name, file name,
version, arrays of stash references, and superclasses, if any.

Browser::LibModule stores objects in a tree similar to the Perl class
hierarchy.  The library module that the Browser::LibModule object
references need not be object oriented.  Every module is a subclass of
Perl's default superclass UNIVERSAL.

Browser::LibModuleSymbol.pm provides lexical scanning and lookup, and
cross referencing subroutines.

Browser::LibSymbolRef provides a few methods for tied objects that correspond
to stash references.

=head2 Running Under Perl/Tk

Browser::LibModule call Tk::Event::DoOneEvent() to provide window
updates.  The function usesTk() determines whether the module is
called from a program that uses Perl/Tk and returns true if called
from a program that has a Tk::MainWindow.  Otherwise usesTk() returns
false.

=head1 REVISION

$Id: LibModule.pm,v 1.5 2004/02/14 22:19:06 kiesling Exp $

=head1 COPYRIGHT

Copyright © 2001-2004 Robert Kiesling, rkies@cpan.org.

Licensed using the same terms as Perl.  Refer to the file,
"Artistic," for information.

=head1 SEE ALSO

Browser::LibModuleSymbol(3), Lib::SymbolRef(3), Tk::Browser(3), perlmod(1),
perlmodlib(1), perl(1).

=cut

sub new {
    my $proto = shift;
    my $class = ref( $proto ) || $proto;
    my $self = {
	children => [],
	parents => '',
	pathname => '',
	basename => '',
	packagename => '',
	version => '',
	superclasses => undef,  
	baseclass => '',
	moduleinfo => undef,
	symbols => []
	};
    bless( $self, $class);
    return $self;
}

# Given a file base name, return the Module object.
sub retrieve {
    my $parent = shift;
    my ($n) = @_;
    if ( $parent -> {basename}  =~ /^$n/ ) { 
	return $parent; }
    foreach ( @{$parent -> {children}} ) {
	if ( $_ -> {basename} =~ /^$n/ ) {
	    return $_;
	}
    } 
    foreach ( @{$parent -> {children}} ) {
	if ( retrieve( $_, $n ) ) { 
	    return $_; }
    }
    return undef;
}

# Given a file pathname, return the Module object.
sub pathname_retrieve {
    my $parent = shift;
    my ($n) = @_;
    print "$n\n";
    if ( $parent -> {pathname}  eq $n ) { 
	return $parent; }
    foreach ( @{$parent -> {children}} ) {
	if ( $_ -> {pathname} eq $n ) {
	    print $_ -> {pathname} . "  $n \n";
	    return $_;
	}
    } 
    foreach ( @{$parent -> {children}} ) {
	if ( retrieve( $_, $n ) ) { 
	    return $_; }
    }
    return undef;
}

# Given a module package or sub-package name, return the module object.
# It's probably desirable to use this in preference to retrieve, 
# with external calls, to avoid dealing with the library pathnames 
# unless necessary.
sub retrieve_module {
    my $parent = shift;
    my ($n) = @_;
    if ( $parent -> {packagename}  eq $n ) { 
	return $parent; }
    foreach ( @{$parent -> {children}} ) {
	if ( $_ -> {packagename} eq $n ) {
	    return $_;
	}
    } 
    foreach ( @{$parent -> {children}} ) {
	if ( retrieve( $_, $n ) ) { 
	    return $_; }
    }
    return undef;
}

sub modulepathnames {
    return @modulepathnames;
}

sub libdirectories {
    return @libdirectories;
}

sub scanlibs {
    my $b = shift;
    my $m;
    my ($path, $bname, $ext);
  LOOP: foreach my $i ( @modulepathnames ) {
      ($bname, $path, $ext) = fileparse($i, qw(\.pm$ \.pl$) );
      # Don't use RCS Archives or Emacs bacups
      if( $bname =~ /(,v)|~/ ) { next LOOP; }
      Tk::Event::DoOneEvent(255) if usesTk ();
      if( $bname =~ /UNIVERSAL/ ) {
	  $b -> modinfo( $i );
      } else {
	  $m = new Browser::LibModule;
	  next LOOP if ! $m -> modinfo( $i );
	  $m -> {parents} = $b; 
	  push @{$b -> {children}}, ($m); 
      }
  }
}

sub modinfo {
    my $self = shift;
    my ($path) = @_;
    my ($dirs, $bname, $ext);
    my ($supers, $pkg, $ver, @text, @matches); 
    ($bname, $dirs, $ext) = fileparse($path, qw(\.pm \.pl));
    $self -> {pathname} = $path;
    @text = $self -> readfile;
    my $p = new Browser::LibModuleSymbol;
    return undef if ! $p -> text_symbols( @text, $path );
    $self -> {moduleinfo} = $p ;
    $self -> {packagename} = $p -> {packagename};
    $self -> {version} = $p -> {version};
    # We do a static match here because it's faster
    # Todo: include base classes from "use base" statements.
    @matches = grep /^\@ISA(.*?)\;/, @text;
    $supers = $matches[0];
    $supers =~ s/(qw)|[=\(\)\;]//gms if $supers;
    $self -> {basename} = $bname;
    $self -> {superclasses} = $supers;
    return 1;
}

# See the perlmod manpage
# Returns a hash of symbol => values.
# Handles as separate ref.
# Typeglob dereferencing deja Symdump.pm and dumpvar.pl, et al.
# Package namespace creation and module loading per base.pm.
sub exportedkeys {
    my $m = shift;
    my ($pkg) = @_;
    my $obj;
    my $packagekey; my $val;
    my $rval;
    my $nval;
    my %keylist = ();
    $m -> {symbols} = ();
    my @vallist;
    my $i = 0;
  EACHKEY: foreach $packagekey ( keys %{*{"$pkg"}} ) {
      next unless $packagekey;
      if( defined ($val = ${*{"$pkg"}}{$packagekey} ) ) {
        no warnings; # avoid uninitalized value warnings.
        $rval = $val; $nval = $val; 
	$obj = tie $rval, 'Lib::SymbolRef', $packagekey;
	push @{$m -> {symbols}}, ($obj);
	foreach( @vallist) { if ( $_ eq $rval ) { next EACHKEY } }
	# Replace the static $VERSION and @ISA values 
	# of the initial library scan with the symbol
	# compile/run-time values.
	local (*v) = $val;
	# Look for the stash values in case they've changed 
	# from the source scan.
	if( $packagekey =~ /VERSION/ ) {
	  $m -> {version} = ${*v{SCALAR}};
	}
	if($packagekey =~ /ISA/ ) {
	  $m -> {superclasses} = "@{*v{ARRAY}}";
	}
        use warnings;
      }
    }
    $keylist{$packagekey} = ${*{"$pkg"}}{$packagekey} if $packagekey;
    # for dumping symbol refs to STDOUT.
    # example of how to print listing of symbol refs.
#    foreach my $i ( @{$m -> {symbols}} ) { 
#      foreach( @{$i -> {name}} ) {
#	print $_; 
#      }
#      print "\n--------\n";
#    }
    return %keylist;
}

#
#  Here for example only.  This function (or the statements
# it contains), must be in the package that has the main:: stash
# space in order to list the packages symbols into the correct
# stash context.  
#
# sub modImport {
#  my ($pkg) = @_;
#  eval "package $pkg";
#  eval "use $pkg";
#  eval "require $pkg";
#}

sub readfile {
  my $self = shift;
  my $fn;
  if (@_){ ($fn) = @_; } else { $fn = $self -> PathName; }
  my @text;
  open FILE, $fn or warn "Couldn't open file $fn: $!.\n";
  @text = <FILE>;
  close FILE;
  return @text;
}

# de-allocate module and all its children
sub DESTROY ($) {
    my ($m) = @_;
    @c = $m -> {children};
    $d = @c;
    if ( $d == 0 )  {   
	$m = {
	    children => undef
	};
	return;
      }
    foreach my $i ( @{$m -> {children}} ) {
	Browser::LibModule -> DESTROY($i);
    }
  }

sub libdirs {
    my $f; my $f2;
    my $d; 
    foreach $d ( @INC ) {
	push @libdirectories, ($d);
	opendir DIR, $d;
	@dirfiles = readdir DIR;
	closedir DIR;
	# look for subdirs of the directories in @INC.
	foreach $f ( @dirfiles ) {
	    next if $f =~ m/^\.{1,2}$/ ;
	    $f2 = $d . '/' . $f;
	    if (opendir SUBDIR, $f2 ) {
		push @libdirectories, ($f2);
		&libsubdir( $f2 );
		closedir SUBDIR;
	    }
	}
    }
}

sub libsubdir {
    my ($parent) = @_;
    opendir DIR, $parent;
    my @dirfiles = readdir DIR;
    closedir DIR;
    foreach (@dirfiles) {
	next if $_ =~ m/^\.{1,2}$/ ;
	my $f2 = $parent . '/' . $_;
	if (opendir SUBDIR, $f2 ) {
	    push @libdirectories, ($f2);
	    libsubdir( $f2 );
	    closedir SUBDIR;
	}
    }
}

sub module_paths {
    my $self = shift;
    my ($f, $pathname, @allfiles);
    Tk::Event::DoOneEvent(255) if usesTk ();
    foreach ( @libdirectories ) {
	opendir DIR, $_;
	@allfiles = readdir DIR;
	closedir DIR;
	foreach $f ( @allfiles ) {
	    if ( $f =~ /\.p[lm]/ ) {
		$pathname = $_ . '/' . $f;
		push @modulepathnames, ($pathname);
	    }
	}
    }
}


sub Children {
    my $self = shift;
    if (@_) { $self -> {children} = shift; }
    return $self -> {children}
}

sub Parents {
    my $self = shift;
    if (@_) { $self -> {parents} = shift; }
    return $self -> {parents}
}

sub PathName {
    my $self = shift;
    if (@_) { $self -> {pathname} = shift; }
    return $self -> {pathname}
}

sub BaseName {
    my $self = shift;
    if (@_) { $self -> {basename} = shift; }
    return $self -> {basename}
}

sub PackageName {
    my $self = shift;
    if (@_) { $self -> {packagename} = shift; }
    return $self -> {packagename}
}

sub Symbols {
    my $self = shift;
    if (@_) { $self -> {symbols} = shift; }
    return $self -> {symbols}
}

###
### Version, SuperClass -- Module.pm uses hashref directly.
###
sub Version {
    my $self = shift;
    if (@_) { $self -> {version} = shift; }
    return $self -> {version}
}

sub SuperClasses {
    my $self = shift;
    if (@_) { $self -> {superclasses} = shift; }
    return $self -> {superclasses}
}

sub BaseClass {
    my $self = shift;
    if (@_) { $self -> {baseclass} = shift; }
    return $self -> {baseclass}
}

sub ModuleInfo {
    my $self = shift;
    if (@_) { $self -> {moduleinfo} = shift; }
    return $self -> {moduleinfo}
}

sub Import {
  my ($pkg) = @_;
  &Exporter::import( $pkg ); 
}

sub usesTk {
  return ( exists ${"main\:\:"}{"Tk\:\:"} );
}

1;