view release on metacpan or  search on metacpan

AuthTkt.pm  view on Meta::CPAN

  h => 3600,
  d => 86400,
  w => 7 * 86400,
  M => 30 * 86400,
  y => 365 * 86400,
);
sub convert_time_seconds
{
    my $self = shift;
    local $_ = shift;
    return $1 if m/^\s*(\d+)\s*$/;
    my $sec = 0;
    while (m/\G(\d+)([shdwmMy])\b\s*/gc) {
        my $amt = $1;
        my $unit = $2 || 's';
        $sec += $amt * $units{$unit};
#       print STDERR "$amt : $unit : $sec\n";
    }
    return $sec;
}

# Parse (simplistically) the given apache config file for TKTAuth directives
sub parse_conf
{
    my $self = shift;
    my ($conf) = @_;

    my %seen = ();
    open CF, "<$conf" or
        die "[$me] open of config file '$conf' failed: $!";

    # Take settings from first instance of each TKTAuth directive found
    local $/ = "\n";
    while (<CF>) {
        if (m/^\s*(${PREFIX}\w+)\s+(.*)/) {
            $seen{$1} = $2 unless exists $seen{$1};
        }
    }

    close CF;
    die "[$me] TKTAuthSecret directive not found in config file '$conf'"
        unless $seen{TKTAuthSecret};

    # Set directives as $self attributes
    my %merge = ( %seen );
    for my $directive (keys %merge) {
        local $_ = $directive;
        s/^TKTAuth(\w)/\L$1/;
        s/([a-z])([A-Z]+)/\L$1_$2/g;
        $merge{$directive} =~ s/^"([^"]+)"$/$1/ if $merge{$directive};
        if ($BOOLEAN{$directive}) {
            $merge{$directive} = 0 
                if $merge{$directive} =~ m/^(off|no|false)$/i;
            $merge{$directive} = 1 
                if $merge{$directive} =~ m/^(on|yes|true)$/i;
        }
        elsif (defined $merge{$directive}) {
            $merge{$directive} =~ s/^\s+//;
            $merge{$directive} =~ s/\s+$//;
        }
        if ($directive eq 'TKTAuthCookieExpires' || $directive eq 'TKTAuthTimeout') {
          $self->{$_} = $self->convert_time_seconds($merge{$directive});
        }
        # Don't allow TKTAuthDebug to turn on debugging here
        elsif ($directive ne 'TKTAuthDebug') {
          $self->{$_} = $merge{$directive};
        }
    }
}

# Process constructor args
sub init
{
    my $self = shift;
    my %arg = @_;

    # Check for invalid args
    for (keys %arg) {
        croak "[$me] invalid argument to constructor: $_" unless exists $ATTR{$_};
    }

    # Parse config file if set
    if ($arg{conf}) {
        $self->parse_conf($arg{conf});
    }

    # Store/override from given args
    $self->{$_} = $arg{$_} foreach keys %arg;

    croak "[$me] bad constructor - 'secret' or 'conf' argument required"
        unless $self->{conf} || $self->{secret};
    croak "[$me] invalid digest_type '" . $self->{digest_type} . "'"
        unless $DIGEST_TYPE{ $self->{digest_type } };

    $self;
}

# Constructor
sub new
{
    my $class = shift;
    my $self = { %DEFAULTS };
    bless $self, $class;
    $self->init(@_);
}

# Setup autoload accessors/mutators
sub AUTOLOAD {
    my $self = shift;
    my $attr = $AUTOLOAD;
    $attr =~ s/.*:://;
    die qq(Can't locate object method "$attr" via package "$self")
        unless $ATTR{$attr};
    @_ and $self->{$attr} = $_[0];
    return $self->{$attr};
}

sub DESTROY {}

sub errstr
{