package Apache::Dispatch::Util;

use strict;
use warnings;

=head1 NAME

  Apache::Dispatch::Util - methods for Apache::Dispatch and Apache2::Dispatch

=head1 DESCRIPTION

This package provides methods common to Apache::Dispatch and Apache2::Dispatch.

=head1 VARIABLES

=over 4

=item B<@_directives>

Private lexical array which contains the directives for configuration.  Used
by the directives() method.

=back

=cut

my @directives = (

    #------------------------------------------------------------------
    # DispatchPrefix defines the base class for a given <Location>
    #------------------------------------------------------------------
    {
     name         => 'DispatchPrefix',
     errmsg       => 'a class to be used as the base class',
     args_how     => 'TAKE1',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchExtras defines the extra dispatch methods to enable
    #------------------------------------------------------------------
    {
     name         => 'DispatchExtras',
     errmsg       => 'choose any of: Pre, Post, or Error',
     args_how     => 'ITERATE',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchStat enables module testing and subsequent reloading
    #------------------------------------------------------------------
    {
     name         => 'DispatchStat',
     errmsg       => 'choose one of On, Off, or ISA',
     args_how     => 'TAKE1',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchAUTOLOAD defines AutoLoader behavior
    #------------------------------------------------------------------
    {
     name         => 'DispatchAUTOLOAD',
     errmsg       => 'choose one of On or Off',
     args_how     => 'FLAG',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchDebug defines debugging verbosity
    #------------------------------------------------------------------
    {
     name         => 'DispatchDebug',
     errmsg       => 'numeric verbosity level',
     args_how     => 'TAKE1',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchISA is a list of modules your module should inherit from
    #------------------------------------------------------------------
    {
     name         => 'DispatchISA',
     errmsg       => 'a list of parent modules',
     args_how     => 'ITERATE',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchLocation allows you to redefine the <Location>
    #------------------------------------------------------------------
    {
     name         => 'DispatchLocation',
     errmsg       => 'a location to replace the current <Location>',
     args_how     => 'TAKE1',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchRequire require()s the class
    #------------------------------------------------------------------
    {
     name         => 'DispatchRequire',
     errmsg       => 'choose one of On or Off',
     args_how     => 'FLAG',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchFilter makes the dispatched handler Apache::Filter aware
    #------------------------------------------------------------------
    {
     name         => 'DispatchFilter',
     errmsg       => 'choose one of On or Off',
     args_how     => 'FLAG',
     req_override => 'OR_ALL',
    },

    #------------------------------------------------------------------
    # DispatchUppercase converts the first char of a class to uppercase
    #------------------------------------------------------------------
    {
     name         => 'DispatchUpperCase',
     errmsg       => 'choose one of On or Off',
     args_how     => 'FLAG',
     req_override => 'OR_ALL',
    },
);

# create global hash to hold the modification times of the modules
my %stat = ();

=head1 METHODS

=over 4

=item C<directives>

Provides the configuration directives in an array or array reference

  $directives = Apache::Dispatch::Util->directives;
  @directives = Apache::Dispatch::Util->directives;

=over 4

=item class: C<Apache::Dispatch::Util> ( class )

The calling class

=item ret: C<$directives|@directives> ( ARRAY | ARRAY ref )

Returns the directives in an array or array reference depending on the context
in which it is called.

=back

=cut

sub directives {
    my $class = shift;
    return wantarray ? @directives : \@directives;
}

=item bogus_uri

=cut

sub bogus_uri {
	my ($class, $uri) = @_;
    if ($uri =~ m![^\w/-]!) {
		return 1;
	}
	return;
}
#*********************************************************************
# the below methods are not part of the external API
#*********************************************************************

sub _stat {
    
	#---------------------------------------------------------------------
    # stat and reload the module if it has changed...
    # this method is for internal use only
    #---------------------------------------------------------------------
	
	my $pkg = shift;
    my ($class, $log) = @_;

    (my $module = $class) =~ s!::!/!g;

    $module .= ".pm";

    $stat{$module} = $^T unless $stat{$module};

    if ($INC{$module}) {
        $log->info("\tchecking $module for reload in pid $$...");

        my $mtime = (stat $INC{$module})[9];

        unless (defined $mtime && $mtime) {
            $log->warn("Apache::Dispatch cannot find $module!");
            return 1;
        }

        if ($mtime > $stat{$module}) {

            # turn off warnings for this bit...
            local $^W;

            delete $INC{$module};
            eval { require $module };

            if ($@) {
                $log->error("Apache::Dispatch: $module failed reload! $@");
                return;
            }
            elsif (!$@) {
                $log->debug("\t$module reloaded");
            }
            $stat{$module} = $mtime;
        }
        else {
            $log->info("\t$module not modified");
        }
    }
    else {
        $log->warn("Apache::Dispatch: $module not in \%INC!");
    }

    return 1;
}

sub _recurse_stat {

    #---------------------------------------------------------------------
    # recurse through all the parent classes of the current class
    # and call _stat on each
    # this method is for internal use only
    #---------------------------------------------------------------------

    my ($class, $log) = @_;

    my $rc = _stat($class, $log);

    return unless $rc;

    # turn off strict here so we can get at the class @ISA
    no strict 'refs';

    foreach my $package (@{"${class}::ISA"}) {
        $rc = _recurse_stat($package, $log);
        last unless $rc;
    }

    return $rc;
}

sub _set_ISA {

    #---------------------------------------------------------------------
    # set the ISA array for the class
    # this method is for internal use only
    #---------------------------------------------------------------------
    my ($pkg, $class, $log, @parents) = @_;

    # turn off strict here so we can get at the class @ISA
    no strict 'refs';

    $log->debug("\t\@ISA for $class currently contains ",
                (join ", ", @{"${class}::ISA"}));
    $log->debug("\tabout to merge ", (join ", ", @parents));
    
	# only add classes to @ISA if they are not there already
    my %seen;

    @{"${class}::ISA"} = grep !$seen{$_}++, (@{"${class}::ISA"}, @parents);
	
	$log->debug("\t\@ISA for $class now contains ",
                (join ", ", @{"${class}::ISA"}));

    return 1;
}

#---------------------------------------------------------------------
# Apache configuration methods
#---------------------------------------------------------------------

sub _new {
    return bless {}, shift;
}

sub DIR_CREATE {
    my $class = shift;
    my $self  = $class->_new;

    $self->{_stat}     = "Off";    # no reloading by default
    $self->{_autoload} = 0;        # no autloading by default
    $self->{_require}  = 0;        # no require()ing by default

    #  warn "inside DIR_CREATE";
    return $self;
}

sub DIR_MERGE {
    my ($parent, $current) = @_;
    my %new = (%$parent, %$current);

    #  warn "inside DIR_MERGE";
    return bless \%new, ref($parent);
}

sub _translate_uri {

    #---------------------------------------------------------------------
    # take the uri and return a class and method
    # this method is for internal use only
    #---------------------------------------------------------------------

	my $pkg = shift;
    my ($r, $prefix, $newloc, $log, $debug) = @_;

    my $uri = $r->uri;
    
	my $location;

    # change all the / to ::
    (my $class_and_method = $r->uri) =~ s!/!::!g;
    
	if ($newloc) {
        $log->info("\tmodifying location from ", $r->location, " to $newloc")
          if $debug > 1;
        ($location = $newloc) =~ s!/!::!g;
    }
    else {
        ($location = $r->location) =~ s!/!::!g;
    }

    # strip off the leading and trailing :: if any
    $class_and_method =~ s/^::|::$//g;
    $location         =~ s/^::|::$//g;

    # substitute the prefix for the location
    # <Location /> is a special case that we can deal with
    # (but not advertise :)
    my $times;

    if ($location) {
        $times = $class_and_method =~ s/^\Q$location/$prefix/e;
    }
    else {

        # <Location />
        $prefix .= "::";
        $times = $class_and_method =~ s/^/$prefix/e;
    }

    unless ($times) {
        $log->info("\tLocation substitution failed - uri not translated")
          if $debug > 1;

        return (undef, undef);
    }

    my ($class, $method);

    if ($prefix eq $class_and_method) {
        $method = "dispatch_index";
        $class  = $prefix;
    }
    else {
        ($class, $method) = $class_and_method =~ m/(.*)::(.*)/;
        $method = "dispatch_$method";
    }

    return ($class, $method);
}

sub _check_dispatch {

    #---------------------------------------------------------------------
    # see if class->method() is a valid call
    # this method is for internal use only
    #---------------------------------------------------------------------
	
	my $pkg = shift;
	
	my ($object, $method, $autoload, $log, $debug) = @_;

    my $class = ref($object);

    my $coderef;

    $log->info("\tchecking the validity of $class->$method...")
      if $debug > 1;

    if ($autoload) {
		$coderef = $object->can($method) || $object->can("AUTOLOAD");
    }
    else {
        $coderef = $object->can($method);
    }

    if ($coderef && $debug > 1) {
        $log->info("\t$class->$method is a valid method call");
    }
    elsif ($debug > 1) {
        $log->info("\t$class->$method is not a valid method call");
    }

    return $coderef;
}

sub DispatchLocation {
    my ($cfg, $parms, $arg) = @_;

    $cfg->{_newloc} = $arg;
}

sub DispatchPrefix {
    my ($cfg, $parms, $arg) = @_;

    $cfg->{_prefix} = $arg;
}

sub DispatchExtras {
    my ($cfg, $parms, $arg) = @_;

    if ($arg =~ m/^(Pre|Post|Error)$/i) {
        push @{$cfg->{_extras}}, uc($arg)
          unless grep /$arg/i, @{$cfg->{_extras}};
    }
    else {
        die "Invalid DispatchExtra $arg!";
    }
}

sub DispatchISA {
    my ($cfg, $parms, $arg) = @_;

    push @{$cfg->{_isa}}, $arg
      unless grep /$arg/, @{$cfg->{_isa}};
}

sub DispatchStat {
    my ($cfg, $parms, $arg) = @_;

    if ($arg =~ m/^(On|Off|ISA)$/i) {
        $cfg->{_stat} = uc($arg);
    }
    else {
        die "Invalid DispatchStat $arg!";
    }
}

sub DispatchRequire {
    my ($cfg, $parms, $arg) = @_;
    
	$cfg->{_require} = $arg;
}

sub DispatchFilter {
    my ($cfg, $parms, $arg) = @_;

    $cfg->{_filter} = $arg;
}

sub DispatchAUTOLOAD {
    my ($cfg, $parms, $arg) = @_;

    $cfg->{_autoload} = $arg;
}

sub DispatchUpperCase {
    my ($cfg, $parms, $arg) = @_;

    $cfg->{_uppercase} = $arg;
}

sub DispatchDebug {
    my ($cfg, $parms, $arg) = @_;

    $cfg->{_debug} = $arg;
}

=pod

=back

=cut

1;