package PSP::Loader;

# Copyright (c) 2000, FundsXpress Financial Network, Inc.
# This library is free software released under the GNU Lesser General
# Public License, Version 2.1.  Please read the important licensing and
# disclaimer information included below.

# $Id: Loader.pm,v 1.1.1.2 2003/12/06 19:47:26 hartmans Exp $

use strict;

=head1 NAME

 PSP::Loader - determines pile from configuration, and initializes it.

=head1 SYNOPSIS

 # more later.

=head1 DESCRIPTION

Generally all the PSP piles for a particular website are stored in a
    single filesystem directory.  This directory, the piles and all
    the webpages contained within the piles need to be mapped from
    filesystem space into URI space so that incoming web requests can
    be directed to the appropriate  page.  The Loader is responsible
    for this mapping.

Each Loader object corresponds to a single level within the PSP name
    tree, or to all the pages in a given pile.  The F<psp.conf> file
    generally creates a Loader called C<Pile> at the directory
    containing all PSP piles.  Then it uses the C<mount> method or the
    C<auto_populate> method to add Loaders for each pile to the
    namespace.

=cut

use Error qw(:try);
use PSP::Utils;
use PSP::parent;
use PSP::share;

use vars qw(@ISA);
@ISA = qw(PSP::parent PSP::share);

=head1 METHODS

=head2 new

  instance or static
  (Loader $this) new (string $name,
		      [ string $url,
		      [ string $path ]])

DESCRIPTION:

Instantiates a Loader object. C<$name> is required and is
the name of the pile for which Loader will be 'working for.'

=cut

sub new {
  my ($parent,$name,$url,$path) = @_;

  # Create the object from parent.
  my $this = PSP::parent::new($parent);

  # determine this pile's class name from first argument.
  # if the first argument is not a reference, it is a class and not a parent.
  my $class = ref($parent)||$parent;
  ref($parent) or undef $parent;

  # name is required.  default url derived from name.
  # url is used to map a parent's mount url to a class name.
  # a class name is used to identify a (pile) class and possibly a file.
  defined $name or throw
    Error::Simple("a name is a required $class parameter.");
  defined $url or
    ($url = $name) =~ s/::+/\//g;

  # remove leading slash or url.
  # (this interpretation may change if we abandon a simple flat model.)
  $url =~ s/^\/+//;

  # the path to this loader node.
  # if paths are never mentioned, files are not expected.
  # default path is derived from parent path and class name.
  # (enforce a flat default file structure for now.)
  if (! defined($path) and $parent and defined $parent->{path}) {
    $path = $parent->{path};
    if (-d $path) {
      $path .= "/$name.pile";
    } elsif (-f $path) {
      $path =~ s!/[^/]+$!/$name.pile!;
    } else {
      $path = "$name.pile";
    }
  }

  # Populate the object.
  $this->{name}        = $name;
  $this->{url}         = $url;
  $this->{path}        = $path;
  $this->{loaded}      = undef; # maps loader to return value of require()
  $this->{mounted}     = {}; # maps url chunk to a child
  $this->{file_stat}   = {}; # stat(2) of the file if path is specified.
  $this->{shared_vars} = {}; # maps variable name to prev variable ref

  return $this;
}

=head2 mount

 instance
 () mount ( [ new() arguments ] )

 instance
 () unmount (string $name)

DESCRIPTION:

Mounts a pile to a mount point. Any pages existing under (directly or
indirectly) the C<$mount_point> will be redirected to the
C<$sub_pile>. If C<$location> fails C<-f>, then then an exception of
type C<Error> will be thrown. Note that the C<$mount_point> can be
specified with either '/' or '::'. Also, the C<$mount_point> may end
in '/' or not (internally, it will be removed).

EXAMPLE:

   $loader->mount( 'foo', 'foo', 'foo.pile' )

This mounts foo.pile onto the URI foo and asserts that the name of all
    packages in foo.pile will be the name of the loader plus
    C<::foo>.  That is, if C<Loader> is the normal top-level loader,
    C<Pile::foo>.

    $loader->unmount ($map_point);

This removes all mappings revolving around C<$map_point> from the
Loader. Unless remounted (through C<mount>), then pages under
the C<$mount_point> will not be redirected.

mount is a constructor of children.
unmount is a destructor of children.

=cut

sub mount {
  my ($this,@args) = @_;

  my $child = $this->new(@args) or return;
  $this->{mounted}->{$child->{url}} = $child;

  return $child;
}

sub unmount {
  my ($this, $name_pattern) = @_;

  # find all children that match input pattern.
  $name_pattern ||= "";
  my @to_unmount = grep { $_->{url} =~ /^$name_pattern$/ } $this->children();

  my @unmounted;
  for my $child (@to_unmount) {

    # gather lost children while ye may (recurse.)
    push @unmounted, $child->unmount($name_pattern);

    # remove this child and remember it.
    delete $this->{mounted}->{$child->{url}};
    $this->del_child($child);
    push @unmounted, $child;
  }

  return @unmounted;
}

=head2 load and unload

 instance
 (string return_values[]) load ([string fname[, string class]])

 instance
 (string return_values[]) unload ( void )

DESCRIPTION:

Ensures that the C<class> associated with this loader node, whose
implementation possibly resides in C<fname> has been loaded.  It also
recurses into its children nodes.  By default, C<fname> is
C<$this->{path}> and C<class> is C<$this->class_name>.

In this base implementation, load() calls the _load() subroutine to load
the specified file, and unload() calls the _unload() subroutine to unload
it.  load() and unload() return all the recursed return values of _load()
or _unload().

See _load() and _unload() for more information.

At the top of load(), a call is made to check_auto_die(), which is capable
of dying if it detects that a change has been made to a pile.  This
generally has the effect of causing 1 request to fail with a status page,
after which the web server will start up a new piledriver.

EXAMPLE:

  # The following is possible, but most likely undesired.  There is seldom
  # need unload() a pile after some operation.
  for my $child ($loader->children()) {
    $child->load();
    # operation..
    $child->unload();
  }

=cut

sub load {
  my ($this,$fname,$class) = @_;
  $fname ||= $this->{path};
  $class ||= $this->class_name();

  # check to see if the pile has changed and if we want to die.
  $this->check_auto_die($fname);

  #print STDERR "making sure $fname is loaded..\n";
  $this->{loaded} and return @{$this->{loaded}};

  my @ret_values;

  # if a file was determined from the loader node.
  defined $fname and
    push @ret_values, _load($fname,$class);

  # recurse into children.
  for my $child ($this->children()) {
    push @ret_values, $child->load();
  }

  $this->{loaded} = \@ret_values;

  return @ret_values;
}

# virtual method for undoing the load() operation.
sub unload {
  my ($this,$fname,$class) = @_;
  $fname ||= $this->{path};
  $class ||= $this->class_name();
  my @ret_values;

  delete $this->{loaded};

  # Recurse into children first. (reverse of load()).
  for my $child ($this->children()) {
    push @ret_values, $child->unload();
  }

  push @ret_values, _unload($fname,$class);

  return @ret_values;
}

=head2 _load and _unload

 package
 (string return value) _load (string fname)

 package
 (string return value) _unload (string fname)

DESCRIPTION

_load() and _unload() facilitate a controlled loading and unloading of the 
script referred to by the input C<$name>.  

_load() is similar to require() in that it loads the specified file and
returns the value returned by the script, but it manages its own notion of
which files it has loaded, and allows the symbols created by this load to
be recovered at a later time.  Furthermore, _load() maintains a reference
count to handle the case when a file is in use by more than one program
construct, and when the file was previously loaded, it returns the
previously cached return value.  _load() will throw an Error::Simple in
the event of an error.

_unload() takes the input C<$fname>, decrements its reference count, and
if the package space is to be recovered, it scans the input file for
package declarations, and removes all the symbols associated with those
packages.  Returns 0 if not unloaded, 1 if unloaded, and -1 on error.

=cut

use vars qw(%INC_ret_values %INC_refcnt);

sub _load {
  my ($fname) = @_;
  #print STDERR "_load($fname) called: refcnt=$INC_refcnt{$fname}\n";

  # fname should be defined.
  throw Error::Simple("\$fname required for _load()\n") if ! defined $fname;

  # see that the file exists and is readable.
  throw Error::Simple("$fname not readable: $!") unless -r $fname;

  # check then increment the INC reference count.
  # if already loaded, return cached ret value.
  return $INC_ret_values{$fname} if $INC_refcnt{$fname}++;

  # Load pile, trapping any errors.
  #print STDERR "** Loading $fname..\n";
  my $ret = do $fname;
  throw Error::Simple("Could not parse $fname: $@\n") if $@;
  throw Error::Simple("Could not read $fname: $!\n") if !defined $ret;
  $INC_refcnt{$fname}++;
  $INC_ret_values{$fname} = $ret;

  return $ret;
}

sub _unload {
  my ($fname) = @_;
  #print STDERR "_unload($fname) called: refcnt=$INC_refcnt{$fname}\n";

  # fname should be defined.
  return -1 if ! defined $fname;

  # Do not unload if module still in use.
  return 0 if (($INC_refcnt{$fname} == 0) or (--$INC_refcnt{$fname} > 0));

  # Scan file for packages.
  my %packages;
  return -1 unless open FILE, $fname;
  while(<FILE>) {
    /^package (\S+);/ and $packages{$1}++;
  }
  close FILE;

  # remove each seen package.
  for my $package (sort keys (%packages)) {
    #print STDERR "** Unloading $package..\n";
    scrub_package($package);
  }

  return 1;
}

=head2 scrub_package

 subroutine
 (void) scrub_package (string package)

DESCRIPTION

scrub_package() is a small utility routine to remove the symbols
associated with the input package name.  I would have used
Symbol::delete_package() which should do the same thing, but it introduces
a nasty memory leak.

=cut

sub scrub_package {
  my ($package) = @_;
  die "Shouldn't delete main package" if $package eq "" || $package eq "main";
  no strict 'refs';
  my $stash = *{$package . '::'}{HASH};
  for my $name (keys %$stash) {
    my $fullname = $package . '::' . $name;
    # Get rid of everything with that name.
    undef $$fullname;
    undef @$fullname;
    undef %$fullname;
    undef &$fullname;
    undef *$fullname;
  }
  use strict;
}

=head2 check_auto_die

 instance
 (void) check_auto_die ([string fname])

DESCRIPTION

If there was a previous stat(2) result, see if it has changed.
if opted and if so, signal the driver to die at the end of request.

=cut

sub check_auto_die {
  my ($this,$fname) = @_;
  return unless $PSP::Conf::psp_do_auto_die;
  $fname ||= $this->{path};
  no strict;

  my @stat = stat($fname) or throw Error::Simple("stat: $fname: $!");
  if ($this->{file_stat}->{$fname} and
      ($stat[9] != $this->{file_stat}->{$fname}->[0] or
       $stat[7] != $this->{file_stat}->{$fname}->[1])) {
    $PSP::Conf::psp_auto_die_fname = $fname;
    throw Error::Simple("Pile changed.  Restarting piledriver.");
  } else {
    $this->{file_stat}->{$fname} = [];
  }
  use strict;
  @{$this->{file_stat}->{$fname}} = ($stat[9],$stat[7]);
}

=head2 list_files

 instance
 (integer newly_mounted) list_files ([string dirname
				      [, string pattern ]])

DESCRIPTION

Returns a list of files found in C<dirname> matching C<pattern>.  By
default, C<dirname> is C<$this->{path}>, and by default, no pattern
matching is done.

The files returned are the paths relative to C<dirname>.

=cut

sub list_files {
  my ($this,$dirname,$pattern) = @_;
  $dirname ||= $this->{path} or return;
  $pattern = "^.*\\.pile\\d*\$" unless defined $pattern;
  my @files;

  # silently return if opendir fails.
  opendir DIR, $dirname or return;

  # add each candidate file, if its not already mounted somewhere.
  while (my $file = readdir DIR) {
    ($file =~ /$pattern/ or next) if $pattern ne "";
    push @files, $file;
  }
  closedir DIR;

  return @files;
}

=head2 auto_populate

 instance
 (integer newly_mounted) auto_populate ([string dirname
					 [, string pattern
					  [, string file_to_name
					   [, string name_to_url ]]]])

DESCRIPTION:

Iterates through pile files in dirname matching pattern, mounting any
piles not yet mounted.  

C<file_to_name> is an optional regular expression replacement to converts
what list_pile_files() returns to a name.  See implementation for default.

C<name_to_url> is an optional regular expression that converts that computed
name to a url.  The default conversion is identity.

See is_mounted() to see by what criteria a pile is judged to be mounted.

Returns the number of newly mounted piles.

=cut

sub auto_populate {
  my ($this,$dirname,$pattern,$file_to_name,$name_to_url) = @_;
  $dirname ||= $this->{path} or return;
  $file_to_name ||= "s!^.*?([^/]+)\\.pile\\d*\$!\$1!";

  my $query = {};
  my $newly_mounted = 0;
  for my $file ($this->list_files($dirname,$pattern)) {
    $query->{file} = $file;
    $query->{path} = $dirname."/".$file; 
    $query->{name} = $query->{file};
    eval '$query->{name} =~ '.$file_to_name if $file_to_name ne "";
    $query->{url} = $query->{name};
    eval '$query->{url} =~ '.$name_to_url  if defined $name_to_url;
    next if $this->is_mounted($query);
    $this->mount($query->{name}, $query->{url}, $query->{path});
    $newly_mounted++;
  }

  return $newly_mounted;
}

=head2 is_mounted

 instance
 (boolean mounted_p) is_mounted ([string name])

or

 instance
 (boolean mounted_p) is_mounted ([Hash query])

DESCRIPTION:

Determines if a pile has been mounted based on input criteria.  If the
first argument is a string, it is assumed to be a name.  Otherwise it is
assumed to be a hash of criteria.

Supported keys:

 path
 name
 url

=cut

sub is_mounted {
  my ($this, $patterns) = @_;

  # typecast the argument into a hash.
  if (! ref $patterns) {
    my $name = $patterns;
    $patterns = { name => $name };
  }

  # find the first child (recursively) which matches input pattern.
  for my $child ($this->children()) {

    for my $pkey (keys %$patterns) {
      my $pattern = $patterns->{$pkey};
      return 1 if $child->{$pkey} =~ /^$pattern$/;
    }
    return 1 if $child->is_mounted($patterns);
  }

  return 0;
}

=head2 url

  instance
  (string url) url ([integer n_to_skip])

DESCRIPTION

Returns the URL that is associated with the current C<Loader> node.  Path
components are retrieved from this current node and each of its recursive
parents nodes.  If C<n_to_skip> is given, that many path components are
skipped from the beginning of the URL.

=cut

sub url {
  my ($this,$n_to_skip) = @_;
  $n_to_skip ||= 0;
  my @url;
  my $node = $this;
  while ($node) {
    unshift @url, $node->{url};
    $node = $node->parent();
  }
  map { shift @url } (1..$n_to_skip);

  return "/".join("/",@url);
}

=head2 class_name

  instance
  (string url) class_name ([string name])

DESCRIPTION

Returns the perl package name that is associated with the current
C<Loader> node.  If no C<name> is given, one is computed and cached.  If a
C<name> is given, this is the value cached and returned.

The package name is assumed to be the name of the root C<Loader> node
concatenated with "::", and the name of the current C<Loader> node.
e.g. for names "Pile" -> "pile" -> "subpile", the computed package name
would be "Pile::subpile".

=cut

sub class_name {
  my ($this,$name) = @_;

  $name and $this->{class_name} = $name;

  # cache class name in similarly named member.
  if (! defined $this->{class_name}) {

    # construct the list of names which will constitute the class name.
    my @names;
    my $node = $this;
#    do { unshift @names, $node->{name};
#       } while (($node = $node->parent()));
    if ($node->parent()) {
      $names[1] = $this->{name};
      do { $names[0] = $node->{name} } while (($node = $node->parent()));
    } else {
      $names[0] = $this->{name};
    }
    # concatenate all the names together.
    $name = join("::",@names);

    $this->{class_name} = $name;
  }

  return $this->{class_name};
}

=head2 map_page

 instance
 (Pile $pile, string $mapped_page) 
    map_page (Object $request, string page_url)

or

 instance
 (Pile $pile, string $mapped_page) 
    map_page (Pile $pile, string page_url)

DESCRIPTION:

Given a request object (typically a C<CGI> object) and a page URL,
map_page() deconstructs the page URL, and maps it to one of its recursive
children.  It returns the found C<Pile> object, and the method name within
that C<Pile> package.

When called with a request object as its first argument, the pile is
instanciated from the first found class, and is initialized by calling
init() with that request object.  When called with a C<Pile> object as its
first argument, this object is re- C<bless> -ed into the package of each
recursive C<Pile>.

=cut

sub map_page {
  my ($this, $pile, $page_url) = @_;

  # remove extraneous crap from input url.  (necessary?)
  $page_url =~ s/\.(html?|pile\d*)//gi;
  #my $leading_slash = '/' if $page_url =~ s/^\/+//;
  my $leading_slash;

  # if the 1st arg is not a pile, it is the CGI object used for new().
  my $cgi = !$pile->isa("PSP::Pile") && $pile;
  undef $pile if $cgi;

  # split the input page url into its path components
  $page_url =~ s/__/\//s;
  my @path = grep { $_ } split /\//, $page_url;

  # iterate through the components of the input page_url.
  # re-construct 
  # find a child of this which matches the possible mount urls
  my ($url, $child, @mnt_path);
  while (my $name = shift @path) {
    push @mnt_path, $name;
    $url = $leading_slash.join('/',@mnt_path);
    $child = $this->{mounted}->{$url} and last;
  }

  if (!$child and $this->{mounted}->{""}) {
    $child = $this->{mounted}->{""};
    @path = @mnt_path;
    @mnt_path = ();
  }

  if (!$child) {

    $page_url = join("/",@mnt_path);

  } else {

    $page_url = join("/",@path);

    # load the child.
    $child->load();

    # if we don't have a pile yet, create it.  otherwise, re-bless it.
    my $class = $child->class_name();
    if (! $pile) {
      $pile = $class->new();
      $pile->init($cgi);
    } else {
      bless $pile, $class;
    }

    # associate this (possibly new) pile with the child of this iteration.
    $pile->loader($child);

    # call the setup method of this pile and take heed of any new page name.
    my ($new_page_url) = $pile->setup($page_url);

    # have the child expect variables from its parent.
    $child->share();

    # recurse into this child.
    return $child->map_page($pile,$new_page_url||$page_url);
  }

  # if we have not found a pile, return undef == error.
  return unless $pile;

  # Calculate and assign the page name.
  my $page_name = $pile->page_name($page_url);

  # return the pile and the page name.
  return($pile, $page_name);
}

=head2 dumper

  instance
  (string output) dumper (void)

DESCRIPTION

Returns the output of C<Data::Dumper>, slightly cleaned up.

=cut

sub dumper {
  my ($this) = @_;
  return PSP::Utils::dump_object($this,'$Loader');
}

# erf.
sub hush_silly_strict_warnings {
  return;
  $PSP::Conf::psp_do_auto_die = $PSP::Conf::psp_auto_die_fname;
}

1;
__END__

=head1 BUGS

No known bugs, but this does not mean no bugs exist.

=head1 SEE ALSO

L<CGI>, L<PSP::Loader>, L<PSP::Log>, L<PSP::Conf>

=head1 COPYRIGHT

 PSP - Perl Server Pages
 Copyright (c) 2000, FundsXpress Financial Network, Inc.

 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2 of the License, or (at your option) any later version.

 BECAUSE THIS LIBRARY IS LICENSED FREE OF CHARGE, THIS LIBRARY IS
 BEING PROVIDED "AS IS WITH ALL FAULTS," WITHOUT ANY WARRANTIES
 OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, WITHOUT
 LIMITATION, ANY IMPLIED WARRANTIES OF TITLE, NONINFRINGEMENT,
 MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, AND THE
 ENTIRE RISK AS TO SATISFACTORY QUALITY, PERFORMANCE, ACCURACY,
 AND EFFORT IS WITH THE YOU.  See the GNU Lesser General Public
 License for more details.

 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA

=cut