view release on metacpan or  search on metacpan

lib/Apache2/ClickPath/Store.pm  view on Meta::CPAN

  return;
}

sub cleanup {
  my ($c, $cfg)=@{$_[0]};

  my $d=$cfg->{"ClickPathStoreDirectory"};
  my $tmout=$cfg->{"ClickPathStoreTimeout"};
  my $interval=$cfg->{"ClickPathStoreCleanupInterval"}||$cleanupdefault;
  my $time=time;

  unless( -f "$d/#lastcleanup" ) {
    open my $f, ">$d/#lastcleanup"
      or do {
	$c->base_server->log->error('['.__PACKAGE__."] Cannot create $d/#lastcleanup: $!");
	return;
      };
    undef $f;
  }

  open my $f, "<$d/#lastcleanup"
    or do {
      $c->base_server->log->error('['.__PACKAGE__."] Cannot open $d/#lastcleanup: $!");
      return;
    };

  flock $f, LOCK_EX|LOCK_NB or return; # another cleanup is running

  my $lasttime=(stat "$d/#lastcleanup")[9];

  if( $time-$lasttime>$interval ) {
    utime $time, $time, "$d/#lastcleanup";

    opendir my $D, $d
      or do {
	$c->base_server->log->error('['.__PACKAGE__."] Cannot opendir $d: $!");
	return;
      };
    my @l=readdir $D;
    closedir $D;

    $c->base_server->log->debug("Cleaning up $d");

    foreach my $el (@l) {
      next if( $el=~/^\.\.?$/ ); # skip . and ..
      next if( $el eq '#lastcleanup' );

      # cleanup is done in 2 stages. At first the directory name is
      # prepended a hash sign (#) and another cleanup interval
      # is waited to let pending requests be served. Then at stage 2 the
      # directory is removed.
      if( $time-(stat $d.'/'.$el)[9]>$tmout ) {
	if( $el=~/^#/ ) {
	  # stage 2
	  $c->base_server->log->info('['.__PACKAGE__."] $d/$el has expired: deleting");
	  rmtree $d.'/'.$el;
	} else {
	  # stage 1
	  $c->base_server->log->info('['.__PACKAGE__."] $d/$el has expired: marking for deletion");
	  rename "$d/$el", "$d/#$el"
	    or do {
	      $c->log->error('['.__PACKAGE__."] Cannot rename $d/$el to $d/#$el: $! -- deleting $el");
	      rmtree $d.'/'.$el;
	    };
	}
      }
    }
  }
}

sub handler {
  my $r=shift;

  my $restorecwd=Perl::AtEndOfScope->new( sub{chdir shift}, Cwd::getcwd );

  my $cfg=Apache2::Module::get_config( __PACKAGE__, $r->server );

  my $d=$cfg->{"ClickPathStoreDirectory"};

  if( $cfg->{"ClickPathStoreTimeout"} ) {
    # Call cleanup at the end of a connection. So keep-alive requests
    # are served at full speed.
    $r->connection->pool->cleanup_register( \&cleanup, [$r->connection, $cfg] )
      unless( $r->connection->keepalives );
  }

  my ($what, $session, $k, $v, $param);

  if( $r->main and		# is subreq
      $param=$r->pnotes( 'Apache2::ClickPath::StoreClient::storeparams' ) ) {
    ($what, $session, $k, $v)=@{$param}{qw{a s k v}};
  } else {
    $CGI::Q=CGI->new( $r );
    $what=CGI::param( 'a' );
    $session=CGI::param( 's' );
    $k=CGI::param( 'k' );
    $v=CGI::param( 'v' );
  }
  $d.='/'.$session;

  $session=~m!^[^/]+$! or return Apache2::Const::HTTP_BAD_REQUEST;
  $k=~m!^\w+$! or return Apache2::Const::HTTP_BAD_REQUEST;

  my $time=time;
  if( $what eq 'set' ) {
    unless( chdir $d ) {
      mkdir $d or do {
	$r->log->error( '['.__PACKAGE__."] Cannot create directory $d: $!" );
	return Apache2::Const::SERVER_ERROR;
      };
      chdir $d or do {
	$r->log->error( '['.__PACKAGE__."] Cannot chdir to $d: $!" );
	return Apache2::Const::SERVER_ERROR;
      };
    }
    utime $time, $time, '.';	# update times to prevent cleanup
    open my $f, ">$k" or do {
      $r->log->error( '['.__PACKAGE__."] Cannot write $d/$k: $!" );
      return Apache2::Const::SERVER_ERROR;
    };
    print $f $v or do {
      $r->log->error( '['.__PACKAGE__."] Cannot write $d/$k: $!" );