view release on metacpan or  search on metacpan

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN

*unpack_requirement_alternate = \&unpack_requirement_combined;

sub unpack_requirement_not {
    my ($self, $req, $args) = @_;
    no strict 'refs';
    my ($requirement, $arg) = split /\s+/, $args, 2;
    my $sub = "unpack_requirement_".makeVariableName($requirement);
    return [ 'not' => $self->$sub($requirement,$arg) ];
}

# methods for storing

sub default_pack_requirement {
    my ($self, $args) = @_;
    return join(' ',@{$$args[1]});
}
*pack_requirement_subrequest = \&default_pack_requirement;
*pack_requirement_valid_user = \&default_pack_requirement;
*pack_requirement_user = \&default_pack_requirement;
*pack_requirement_group = \&default_pack_requirement;
*pack_requirement_level = \&default_pack_requirement;

sub pack_requirement_combined {
    my ($self, $args) = @_;
    no strict 'refs';
    my $rc = '';
    foreach my $req (@{$$args[1]}) {
        my $sub = "pack_requirement_".makeVariableName($$req[0]);
        my $res = $self->$sub($req);
        $res =~ s/([\\"])/\\$1/g;
        $rc .= $$req[0]." \"$res\" ";
    }
    return substr($rc,0,-1);
}

*pack_requirement_alternate = \&pack_requirement_combined;

sub pack_requirement_not {
    my ($self, $args) = @_;
    no strict 'refs';
    my $sub = "pack_requirement_".makeVariableName($$args[1][0]);
    return $$args[1][0].' '.$self->$sub($$args[1]);
}

sub set_permissions($$@) {
    my ($self, $r, @perms) = @_;
    @perms = map { 'require '.$_->[0].' '.$_->[1]."\n" } @perms;
    if ($r->uri =~ m/#[^\/]*$/) {
        push @perms, "SetHandler perl-script\n";
        push @perms, "PerlHandler \"sub { &Apache::Constants::NOT_FOUND; }\"\n";
    }
    # Enabling write access to httpd config files is dangerous, so you will have to find
    # out yourself what to do. Do this only if you absolutely know what you are doing.
    my $configfile = $r->dir_config(($r->auth_name || 'AxKitSession').'AuthFile') || die 'read the fine manual.';
    local (*IN, *OUT);
    if (substr($configfile,0,1) eq '/') {
        open(IN, $configfile) || die "file open error (read): $configfile";
        open(OUT, ">$configfile.new") || die "file open error (write): $configfile.new";
        while (my $line = <IN>) {
            print OUT $line unless $line eq '# do not modify - autogenerated. # '.$r->uri."\n";
            while (my $line = <IN> && $line ne "# end of autogenerated fragment\n") {}
        }
        close(IN);
        print OUT '# do not modify - autogenerated. # '.$r->uri."\n";
        print OUT '<Location '.$r->uri.">\n";
        print OUT @perms;
        print OUT "</Location>\n";
        print OUT "# end of autogenerated fragment\n";
        close(OUT);
        rename("$configfile.new",$configfile);
    } else {
        my $dir = $r->filename;
        $dir =~ s{[^/]*$}{$configfile};
        my $file = $r->uri;
        $file =~ s{.*\/}{};
        $file .= $r->path_info;
        my @lines;
        if (open(IN, $dir)) {
            @lines = <IN>;
            close(IN);
        }
        open(OUT, ">$dir") || die "file open error (write): $dir";
        my $skip = 0;
        for my $line (@lines) {
            $skip = 1 if $line eq '# do not modify - autogenerated. # '.$r->uri."\n";
            print OUT $line unless $skip;
            $skip = 0 if $line eq "# end of autogenerated fragment\n";
        }
        print OUT '# do not modify - autogenerated. # '.$r->uri."\n";
        print OUT '<Files '.$file.">\n";
        print OUT @perms;
        print OUT "</Files>\n";
        print OUT "# end of autogenerated fragment\n";
        close(OUT);
    }
}

# interfaces for the taglib

sub get_permission_set($$) {
    my ($self, $r) = @_;
    my @rc = ();
    foreach my $req ($self->get_permissions($r)) {
        $$req[1] = '' unless defined $$req[1];
        my $sub = 'unpack_requirement_'.makeVariableName($$req[0]);
        push @rc, $self->$sub(@$req);
    }
    return @rc;
}

sub set_permission_set($$@) {
    my ($self, $r, @reqs) = @_;
    my @rc;
    my $req;
    foreach my $req (@reqs) {
        my $sub = "pack_requirement_".makeVariableName($$req[0]);
        push @rc, [ $$req[0], $self->$sub($req) ];
    }
    $self->set_permissions($r,@rc);
}

# overriding AuthCookieURL to implement OR style require handling
sub authorize ($$;$) {
    my ($self, $r, $reqs) = @_;
    my $auth_type = $self;
    $self->debug(3,"------- authorize(".join(',',@_).")");

    # This is a way to open up some documents/directories
    return OK if lc $r->auth_name eq 'none';
    return OK if $r->uri eq $r->dir_config(($r->auth_name || 'AxKitSession').'LoginScript');
    return OK if ($r->main?$r->main->uri:$r->uri) =~ m/^$redirect_location(\/|$)/;

    if (defined $r->auth_type && $r->auth_type ne $auth_type) {
        # This location requires authentication because we are being called,
        # but we don't handle this AuthType.
        $self->debug(3,"AuthType mismatch: $auth_type != ".$r->auth_type);
        return DECLINED;
    }

    my @reqs = ($reqs?@$reqs:$self->get_permissions($r)) or return DECLINED;

    my $user = $r->connection->user;

    unless ($user) {
        # user is either undef or =0 which means the authentication failed
        $r->log_reason("No user authenticated", $r->uri);
        $self->save_reason('no_user') if ($r->is_main());
        return FORBIDDEN;
    }

    foreach my $req (@reqs) {
        my ($requirement, $args) = split /\s/,$req->{requirement},2;
        $args = '' unless defined $args;