>>>>> "Jeffrey" == Jeffrey W Baker writes:
I've cut down handler.pl to bare minimum.
=== cut handler.pl ==
#!/usr/bin/perl
# $Id: handler.pl,v 1.3 2000/01/14 19:42:16 tarkhil Exp $
#
$ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl/
or die "GATEWAY_INTERFACE not Perl!";
use Apache::Registry;
use Apache::Status;
use Socket;
use Carp qw(cluck confess);
package HTML::Mason;
use HTML::Mason;
use strict;
{
package HTML::Mason::Commands;
use Apache::Registry;
use Apache::Status;
}
my $parser = new HTML::Mason::Parser
(
# allow_globals => [qw($dbh)]
);
my $interp = new HTML::Mason::Interp
(parser=>$parser,
data_dir => "/usr/local/www/tmp",
comp_root => "/usr/local/www");
#$interp->set_global(dbh=>DBI->connect
# ("DBI:mysql:mail2pager",
# "tarkhil", "",
# { RaiseError => 1, PrintError => 1,
# AutoCommit => 1, }
#));
my $ah = new HTML::Mason::ApacheHandler (interp=>$interp,
output_mode=>'batch');
chown ( 60001, 60001, $interp->files_written );
use Apache::Cookie;
use Apache::Session::File;
sub handler {
my ($r) = @_;
return -1
if defined($r->content_type) && $r->content_type !~ m|^text/|io;
my $cook = Apache::Cookie->new($r);
my $cookie = $cook->get('SESSION_ID');
my %session;
tie %session, 'Apache::Session::File', $cookie;
$cook->set(-name => "SESSION_ID", -value => $session{_session_id})
if ( !$cookie );
my $res = $ah->handle_request($r);
untie %session;
return $res;
}
1;
=== cut ===
No globals, yes?
I've used slightly modified File.pm:
== cut Apache::Session::File.pm ===
#############################################################################
#
# Apache::Session::File
# Apache persistent user sessions in the filesystem
# Copyright(c) 1998, 1999 Jeffrey William Baker ([EMAIL PROTECTED])
# Distribute under the Artistic License
#
############################################################################
package Apache::Session::File;
use strict;
use vars qw(@ISA $VERSION);
$VERSION = '1.00';
@ISA = qw(Apache::Session);
use Apache::Session;
use Apache::Session::DLocker;
use Apache::Session::FileStore;
sub get_object_store {
my $self = shift;
return new Apache::Session::FileStore $self;
}
sub get_lock_manager {
my $self = shift;
return new Apache::Session::DLocker $self;
}
1;
=== cut ===
with self-written daemon-based locker
=== cut Apache::Session::DLocker.pm ===
package Apache::Session::DLocker;
use strict;
use IO::Socket;
use vars qw($VERSION);
$VERSION = '1.00';
use constant LockerPort => 2015;
sub new {
my $class = shift;
my $session = shift;
return bless {read => 0, write => 0 }, $class;
}
sub request {
my $self = shift;
my $op = shift;
my $session = shift;
my $ready;
until ($ready) {
my $sock = new IO::Socket::INET(PeerAddr => '127.0.0.1',
PeerPort => LockerPort);
$sock->print(join(' ', $op, $session->{data}->{_session_id}, $$), "\n");
$_ = $sock->getline();
$sock->close;
/OK/ and $ready = 1;
sleep 1 unless $ready;
}
}
sub acquire_read_lock {
my $self = shift;
my $session = shift;
return if $self->{read};
die if $self->{write};
$self->request('LOCKR', $session);
$self->{read} = 1;
}
sub acquire_write_lock {
my $self = shift;
my $session = shift;
return if($self->{write});
$self->request('LOCKW', $session);
$self->{write} = 1;
}
sub release_read_lock {
my $self = shift;
my $session = shift;
die unless $self->{read};
$self->request('ULOCR', $session);
$self->{read} = 0;
}
sub release_write_lock {
my $self = shift;
my $session = shift;
die unless $self->{write};
$self->request('ULOCW', $session);
$self->{write} = 0;
}
sub release_all_locks {
my $self = shift;
my $session = shift;
if($self->{read}) {
$self->release_read_lock($session);
}
if($self->{write}) {
$self->release_write_lock($session);
}
$self->{read} = 0;
$self->{write} = 0;
}
1;
=== cut ===
and the following daemon to aid in debugging:
=== cut lockerd ===
#!/usr/bin/perl
use strict;
use IO::Socket;
use constant LockerPort => 2015;
my $dsock = new IO::Socket::INET(LocalAddr => '127.0.0.1',
LocalPort => LockerPort,
Reuse => 1,
Listen => 5);
die "Cannot allocate socket: $!"
unless defined $dsock;
my %locks;
sub debug {
print @_;
}
# Possible commands:
# LOCKR <session> <pid>
# LOCKW <session> <pid>
# ULOCR <session> <pid>
# ULOCW <session> <pid>
# Possible replies:
# +OK
# -ERR
sub ok {
my $sock = shift;
debug("OK");
$sock->print("+OK\n");
debug("\n");
}
sub err {
my $sock = shift;
debug("ERR");
$sock->print("-ERR\n");
debug("\n");
}
$SIG{INT} = sub {
print "\n\nDumping locks state:\n";
foreach (sort keys %locks) {
print "Session $_:\n";
if (defined($locks{$_}->{write})) {
print " * Write locked by ",$locks{$_}->{write}, "\n";
} else {
print " * No write locks\n";
}
my $reader;
print " * Read locked by: ",
join(', ',sort keys %{$locks{$_}->{read}}), "\n";
}
print "\n==========\n";
};
# Main loop
$| = 1;
while (my $client = $dsock->accept()) {
$_ = $client->getline;
chomp;
next unless (/^([CKLORWU]{5}) ([\da-fA-F]+) (\d+)$/);
$_ = $1;
my $session = $2;
my $pid = $3;
/^LOCKR$/ and do {
debug("$pid is r-locking $session...");
if (defined $locks{$session}->{read}->{$pid}) {
debug("already r-locked: ");
err($client);
next;
}
if (defined $locks{$session}->{write}) {
debug ("already w-locked with ", $locks{$session}->{write}, ": ");
err($client);
next;
}
$locks{$session}->{read}->{$pid} = 1;
ok($client);
next;
};
/^ULOKR$/ and do {
debug("$pid is r-unlocking $session...");
if (defined $locks{$session}->{read}->{$pid}) {
delete $locks{$session}->{read}->{$pid};
ok($client);
next;
}
debug("no lock found:");
err($client);
next;
};
/^LOCKW$/ and do {
debug("$pid is w-locking $session...");
my $myrl = $locks{$session}->{read}->{$pid};
if (scalar keys %{$locks{$session}->{read}} != $myrl) {
debug("already r-locked by ",
join(':', sort keys %{$locks{$session}->{read}}),
": ");
err($client);
next;
}
if (defined $locks{$session}->{write}) {
debug("already w-locked by ", $locks{$session}->{write}, ": ");
err($client);
next;
}
$locks{$session}->{write} = $pid;
ok($client);
next;
};
/^ULOKW$/ and do {
debug("$pid is w-unlocking $session...");
if ($locks{$session}->{write} == $pid) {
ok($client);
next;
}
debug("not w-locked by $pid: ");
err($client);
next;
};
} continue {
$client->close() if defined $client;
}
=== cut ===
Everything is as simple as possible, and on first access to any HTML
page, lockerd informs me about r- or w-locking, but NO UNLOCK EVER
FOLLOWS.
It is beyond my understaning ability to find out why untie do not
force call to DESTROY, and even %session going out-of-scope do not.
>From my earlier expiriments I've found that untie _IS_ called, but
amazingly with no further effect.
Yes, I've tried to undef %session after untie, and even to undef
instead of untie.
Apparently Apache::DB cannot debug handlers, so I'm in total
darkness...
--
Alexander B. Povolotsky [ICQ 18277558]
[2:5020/145] [[EMAIL PROTECTED]]
