view release on metacpan or  search on metacpan

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

# 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');