home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / State.pm < prev    next >
Encoding:
Perl POD Document  |  2002-12-06  |  9.6 KB  |  361 lines
  1. package Apache::ASP::State;
  2.  
  3. use MLDBM;
  4. use MLDBM::Sync 0.25;
  5. use MLDBM::Sync::SDBM_File;
  6. use SDBM_File;
  7. use Data::Dumper;
  8.  
  9. use strict;
  10. no strict qw(refs);
  11. use vars qw(%DB %CACHE $DefaultGroupIdLength);
  12. use Fcntl qw(:flock O_RDWR O_CREAT);
  13. $DefaultGroupIdLength = 2;
  14.  
  15. # Database formats supports and their underlying extensions
  16. %DB = (
  17.        SDBM_File => ['.pag', '.dir'],
  18.        DB_File => [''],
  19.        'MLDBM::Sync::SDBM_File' => ['.pag', '.dir'],
  20.        GDBM_File => [''],
  21.        'Tie::TextDir' => [''],
  22.        );
  23.  
  24. # About locking, we use a separate lock file from the SDBM files
  25. # generated because locking directly on the SDBM files occasionally
  26. # results in sdbm store errors.  This is less efficient, than locking
  27. # to the db file directly, but having a separate lock file works for now.
  28. #
  29. # If there is no $group given, then the $group will be extracted from
  30. # the $id as the first 2 letters of that group.
  31. #
  32. # If the group and the id are the same length, then what was passed
  33. # was just a group id, and the object is being created for informational
  34. # purposes only.  So, we don't create a lock file in this case, as this
  35. # is not a real State object
  36. #
  37. sub new {
  38.     my($asp, $id, $group) = @_;
  39.  
  40.     if($id) {
  41.     $id =~ tr///;
  42.     } else {
  43.     $asp->Error("no id: $id passed into new State");
  44.     return;
  45.     }
  46.  
  47.     # default group is first 2 characters of id, simple hashing
  48.     if($group) {
  49.     $group =~ tr///;
  50.     } else {
  51.     $group = substr($id, 0, $DefaultGroupIdLength)
  52.     }
  53.  
  54.     unless($group) {
  55.     $asp->Error("no group defined for id $id");
  56.     return;
  57.     }
  58.  
  59.     my $state_dir = $asp->{state_dir};
  60.     my $group_dir = $state_dir.'/'.$group;
  61.     my $lock_file = $group_dir.'/'.$id.'.lock';
  62.     my $file = $group_dir.'/'.$id;
  63.  
  64.     # we only need SDBM_File for internal, and its faster so use it
  65.     my($state_db, $state_serializer);
  66.     if($id eq 'internal') {
  67.     $state_db = $Apache::ASP::DefaultStateDB;
  68.     $state_serializer = $Apache::ASP::DefaultStateSerializer;
  69.     } elsif($asp->{Internal} && (length($id) > $DefaultGroupIdLength)) {
  70.     # don't get data for dummy group id sessions
  71.     my $internal = $asp->{Internal};
  72.     my $idata = $internal->{$id};
  73.     if(! $idata->{state_db} || ! $idata->{state_serializer}) {
  74.         $state_db = $idata->{state_db} || $asp->{state_db} || $Apache::ASP::DefaultStateDB;
  75.         $state_serializer = $idata->{state_serializer} || 
  76.           $asp->{state_serializer} || $Apache::ASP::DefaultStateSerializer;
  77.         
  78.         # INIT StateDB && StateSerializer if hitting for the first time
  79.         # only if real id like a session id or application
  80.         if(length($id) > $DefaultGroupIdLength) {
  81.         my $diff = 0;
  82.         if(($idata->{state_db} || $Apache::ASP::DefaultStateDB) ne $state_db) {
  83.             $idata->{state_db} = $state_db;
  84.             $diff = 1;
  85.         }
  86.         if(($idata->{state_serializer} || $Apache::ASP::DefaultStateSerializer) ne $state_serializer) {
  87.             $idata->{state_serializer} = $state_serializer;
  88.             $diff = 1;
  89.         }
  90.  
  91.         if($diff) {
  92.             $asp->{dbg} && $asp->Debug("setting internal data for state $id", $idata);
  93.             $internal->{$id} = $idata;
  94.         }
  95.         }
  96.     } else {
  97.         # this state has already been created
  98.         $state_db = $idata->{state_db};
  99.         $state_serializer = $idata->{state_serializer};
  100.     }
  101.     } else {
  102.     # cache layer doesn't need internal
  103.     ($state_db, $state_serializer) = ($asp->{state_db}, $asp->{state_serializer});
  104.     }
  105.  
  106.     my $self = 
  107.       bless {
  108.          asp=>$asp,
  109.          dbm => undef, 
  110.          'dir' => $group_dir,
  111.          id => $id, 
  112.          file => $file,
  113.          group => $group, 
  114.          group_dir => $group_dir,
  115.          reads => 0,
  116.          state_dir => $state_dir,
  117.          writes => 0,
  118.         };
  119.  
  120.     # short circuit before expensive directory tests for group stub
  121.     if ($group eq $id) {
  122.     return $self;
  123.     }
  124.  
  125.     if($asp->config('StateAllWrite')) {
  126.     $asp->{dbg} and $asp->{state_all_write} = 1;
  127.     $self->{dir_perms} = 0777;
  128.     $self->{file_perms} = 0666;
  129.     } elsif($asp->config('StateGroupWrite')) {
  130.     $asp->{dbg} and $asp->{state_group_write} = 1;
  131.     $self->{dir_perms} = 0770;
  132.     $self->{file_perms} = 0660;
  133.     } else {
  134.     $self->{dir_perms} = 0750;
  135.     $self->{file_perms} = 0640;
  136.     }
  137.  
  138. #    push(@{$self->{'ext'}}, @{$DB{$self->{state_db}}});    
  139. #    $self->{asp}->Debug("db ext: ".join(",", @{$self->{'ext'}}));
  140.  
  141.     # create state directories
  142.     my @create_dirs;
  143.     unless(-d $state_dir) {
  144.     push(@create_dirs, $state_dir);
  145.     }
  146.     # create group directory
  147.     unless(-d $group_dir) {
  148.     push(@create_dirs, $group_dir);
  149.     }
  150.     if(@create_dirs) {
  151.     $self->UmaskClear;
  152.     for my $create_dir (@create_dirs) {
  153. #        $create_dir =~ tr///; # this doesn't work to untaint with perl 5.6.1, use old method
  154.         $create_dir =~ /^(.*)$/s;
  155.         $create_dir = $1;
  156.         if(mkdir($create_dir, $self->{dir_perms})) {
  157.         $asp->{dbg} && $asp->Debug("creating state dir $create_dir");
  158.         } else {
  159.         my $error = $!;
  160.         -d $create_dir || $self->{asp}->Error("can't create group dir $create_dir: $error");
  161.         }
  162.     }
  163.     $self->UmaskRestore;
  164.     }
  165.  
  166.     # INIT MLDBM::Sync DBM
  167.     { 
  168.     local $MLDBM::UseDB = $state_db || 'SDBM_File';
  169.     local $MLDBM::Serializer = $state_serializer || 'Data::Dumper';
  170.     # clear current tied relationship first, if any
  171.     $self->{dbm} = undef; 
  172.     local $SIG{__WARN__} = sub {};
  173.     
  174.     my $error;
  175.     $self->{file} =~ /^(.*)$/; # untaint
  176.     $self->{file} = $1;
  177.     local $MLDBM::RemoveTaint = 1;
  178.     $self->{dbm} = &MLDBM::Sync::TIEHASH('MLDBM', $self->{file}, O_RDWR|O_CREAT, $self->{file_perms});
  179.     $asp->{dbg} && $asp->Debug("creating dbm for file $self->{file}, db $MLDBM::UseDB, serializer: $MLDBM::Serializer");
  180.     $error = $! || 'Undefined Error';
  181.  
  182.  
  183.     if(! $self->{dbm}) {
  184.         $self->{asp}->Error(qq{
  185. Cannot tie to file $self->{file}, $error !!
  186. Make sure you have the permissions on the directory set correctly, and that your
  187. version of Data::Dumper is up to date. Also, make sure you have set StateDir to 
  188. to a good directory in the config file.  StateDir defaults to Global/.state
  189. });
  190.     }
  191.     }
  192.  
  193.     $self;
  194. }
  195.  
  196. sub Init   { shift->{dbm}->CLEAR(); }
  197. sub Size   { shift->{dbm}->SyncSize; }
  198. sub Delete { shift->{dbm}->CLEAR(); }
  199. sub WriteLock { shift->{dbm}->Lock; }
  200. sub ReadLock { shift->{dbm}->ReadLock; }
  201. sub UnLock { shift->{dbm}->UnLock; }
  202.  
  203. sub DeleteGroupId {
  204.     my $self = shift;
  205.  
  206.     my $group_dir = $self->{group_dir};
  207.     if(-d $group_dir) {
  208.     $self->{asp}{Internal}->LOCK;
  209.     if(rmdir($group_dir)) {
  210.         $self->{asp}->Debug("deleting group dir $group_dir");
  211.     } else {
  212.         $self->{asp}->Log("cannot delete group dir $group_dir: $!");
  213.     }
  214.     $self->{asp}{Internal}->UNLOCK;
  215.     }
  216. }
  217.  
  218. sub GroupId { shift->{group}; }
  219.  
  220. sub GroupMembers {
  221.     my $self = shift;
  222.     local(*DIR);
  223.     my(%ids, @ids);
  224.  
  225.     unless(opendir(DIR, $self->{group_dir})) {
  226.     $self->{asp}->Log("opening group $self->{group_dir} failed: $!");
  227.     return [];
  228.     }
  229.  
  230.     for(readdir(DIR)) {
  231.     next if /^\.\.?$/;
  232.     $_ =~ /^(.*?)(\.[^\.]+)?$/;
  233.     next unless $1;
  234.     $ids{$1}++;
  235.     }
  236.  
  237.     # need to explicitly close directory, or we get a file
  238.     # handle leak on Solaris
  239.     closedir(DIR);
  240.  
  241.     # since not all sessions have their own dbms now, find session ids in $Internal too
  242.     if(my $internal = $self->{asp}{Internal}) {
  243.     my $cached_keys = {};
  244.     unless($cached_keys = $self->{asp}{internal_cached_keys}) {
  245.         map {
  246.         if(/^([0-9a-f]{2})/) { 
  247.             $cached_keys->{$1}{$_}++
  248.         }
  249.         } keys %$internal;
  250.         $self->{asp}{internal_cached_keys} = $cached_keys;
  251.     }
  252.     if(my $group_keys = $cached_keys->{$self->{group}}) {
  253.         %ids = ( %ids, %$group_keys );
  254.     }
  255.     }
  256.  
  257.     @ids = keys %ids;
  258.  
  259.     \@ids;
  260. }
  261.  
  262. sub DefaultGroups {
  263.     my $self = shift;
  264.     my(@ids);
  265.     local *STATEDIR;
  266.  
  267.     opendir(STATEDIR, $self->{state_dir}) 
  268.     || $self->{asp}->Error("can't open state dir $self->{state_dir}");
  269.     my $time = time;
  270.     for(readdir(STATEDIR)) {
  271.     next if /^\./;
  272.     next unless (length($_) eq $DefaultGroupIdLength);
  273.     push(@ids, $_);
  274.     }
  275.     closedir STATEDIR;
  276.  
  277.     \@ids;
  278. }
  279.  
  280. sub UmaskClear {
  281.     my $self = shift;
  282.     return if $self->{asp}{win32};
  283.     $self->{umask_restore} = umask(0000);
  284. }
  285.  
  286. sub UmaskRestore {
  287.     my $self = shift;
  288.     return if $self->{asp}{win32};
  289.     if(defined $self->{umask_restore}) {
  290.     umask($self->{umask_restore});
  291.     }
  292. }
  293.  
  294. sub DESTROY {
  295.     my $self = shift;
  296.     return unless %{$self};
  297.     return if $self->{destroyed}++;
  298.     $self->{dbm} && eval { $self->{dbm}->DESTROY };
  299.     $self->{dbm} = undef;
  300. }
  301.  
  302. # don't need to skip DESTROY since we have it defined
  303. # return if ($AUTOLOAD =~ /DESTROY/);
  304. sub AUTOLOAD {
  305.     my $self = shift;
  306.     my $AUTOLOAD = $Apache::ASP::State::AUTOLOAD;
  307.     $AUTOLOAD =~ s/^(.*)::(.*?)$/$2/o;
  308.  
  309.     my $value;
  310.     $value = $self->{dbm}->$AUTOLOAD(@_);
  311.  
  312.     $value;
  313. }
  314.  
  315. sub TIEHASH {
  316.     my $type = shift;
  317.  
  318.     # dual tie contructor, if we receive a State object to tie
  319.     # then just return it, otherwise construct a new object
  320.     # before tieing
  321.     if((ref $_[0]) =~ /State/) {
  322.     $_[0];
  323.     } else {    
  324.     bless &new(@_), $type;
  325.     }
  326. }
  327.  
  328. sub FETCH {
  329.     my($self, $index) = @_;
  330.     my $value;
  331.  
  332.     if($index eq '_FILE') {
  333.     $value = $self->{file};
  334.     } elsif($index eq '_SELF') {
  335.     $value = $self;
  336.     } else {
  337.     $value = $self->{dbm}->FETCH($index);
  338.     $self->{reads}++;
  339.     }
  340.  
  341.     $value;
  342. }
  343.  
  344. sub STORE {
  345.     my $self = shift;
  346.  
  347.     # don't worry about overhead of Umask* routines, the STORE
  348.     # being called is much heavier
  349.     $self->UmaskClear;
  350.     my $rv = $self->{dbm}->STORE(@_);
  351.     $self->UmaskRestore;
  352.     $self->{writes}++;
  353.  
  354.     $rv;
  355. }
  356.  
  357. sub LOCK { my $self = tied(%{$_[0]}); $self->{dbm}->Lock(); }
  358. sub UNLOCK { my $self = tied(%{$_[0]}); $self->{dbm}->UnLock(); }
  359.  
  360. 1;
  361.