frog.raindrop.jp.knowledge

中身はシンプルで、現在ディスクに存在するセッションを列挙するクラスと、CGI::Sessionを継承するが、最終アクセス日時は変更しないクラスです。
列挙するクラスは、CGI::Sessionのドライバごとに、サブクラスを作成します。今回はFileドライバのみ作成しました。
CGI::Sessionを継承するCGI::Session::Sweeper::Itemは、CGI::Session自身が、セッションのロード時にすでに期限切れであれば、セッションを削除する処理を行っているので、それをそっくりコピーして、更新部分をコメントアウトします。

実際に使う場合は以下をSweeper.pmというファイル名で保存して、パスの通るディレクトリのなかに、CGIと言うディレクトリと、その中にSessionと言うディレクトリを作って、その下に置きます。

######################################################################
##クラス    : CGI::Session::Sweeper                                 ##
##概要      : メインクラス                                          ##
##                                                                  ##
######################################################################
package CGI::Session::Sweeper;
require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
    
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
    
);

our $VERSION = '0.01';

#コンストラクタ
#引数      :$_[0],  I,  Scaler,  DSN     (CGI::Session->new の第1引数と同じもの)
#           $_[1],  I,  HashRef, HASHREF (CGI::Session->new の第3引数と同じもの)
sub new {
    my $class   = shift;
    $class      = ref( $class ) || $class;
    my @api_3;
    
    if ( defined $_[0] ) {
        @api_3  =
            map { uc( $_->[0] ) => $_->[1] } 
            map { [ /^(.+):(.+)$/ ] } 
                            split /;/, $_[0] ;
    }
    
    my $self = {
        _OPTIONS    => [ @_ ], 
        _API_3      => {
            DRIVER      => 'File', 
            SERIALIZER  => 'Default', 
            ID          => 'MD5', 
            @api_3
        }
    };
    
    # ドライバに対応するサブクラスにblessする
    $class  .= "::$self->{_API_3}->{DRIVER}";
    return bless( $self, $class );
}


#セッション一括削除処理
#引数      :なし
sub sweep {
    # sweep ! :)
    my $self        = shift;
    my %sessions    = %{ $self->_scan_sessions() };
    my @args;
    
    $args[0, 2]     = @{ $self->{_OPTIONS} }[0, 1];
    
    while ( my( $id, $val ) = each %sessions ) {
        next unless( $id );
        
        $args[1]        = $id;
        my $oSubItem    = CGI::Session::Sweeper::Item->new( @args );
        #↑ CGI::Session->new()から
        #   CGI::Session::Sweeper::Item->_init_old_session()がコールされる
        
        undef( $oSubItem );
    }
    return 1;
}

#セッション列挙処理
#引数      :なし
#説明      :現在ディスク上に存在するセッションを列挙したHashRefを返す。
#           ※ 各ドライバごとのサブクラスからオーバーロードされる
#戻り値    :{ セッションID => ドライバ内での識別子とか(何でもいい) }
sub _scan_sessions { return {} }



######################################################################
##クラス    : CGI::Session::Sweeper::Item                           ##
##概要      : それぞれのセッションについて、有効期限を調べ、        ##
##          : 期限切れなら開放時に削除                              ##
##            CGI::Sessionを継承する                                ##
######################################################################
package CGI::Session::Sweeper::Item;

use CGI::Session;

#いらないメソッドをオーバーロードしよう!
our @ISA = qw(CGI::Session);

#コンストラクタ
#引数      :$_[0],  I,  Scaler,         DSN     (CGI::Session->new の第1引数と同じもの)
#           $_[1],  I,  Scaler or CGI,  SID     (CGI::Session->new の第2引数と同じもの)
#           $_[2],  I,  HashRef,        HASHREF (CGI::Session->new の第3引数と同じもの)
sub new {
    my $class   = shift;
    $class      = ref( $class ) || $class;
    
    # 親クラスを生成
    my $self    = CGI::Session->new( @_ );
    
    return bless( $self, $class );
    
}


#既存のセッションをロードする
#引数      :$_[1],  I,  Scaler, セッションID
#説明      :CGI::Session->_initよりコールされる
#           スーパークラスのメソッドより、タッチした日付を
#           更新したりする処理をコメントアウトしたのみ
#戻り値    :削除時 undef, 以外は 1
sub _init_old_session {
    my ($self, $claimed_id) = @_;

    my $options = $self->{_OPTIONS} || [];
    my $data = $self->retrieve($claimed_id, $options);
    
    # Session was initialized successfully
    if ( defined $data ) {

        $self->{_DATA} = $data;

#        # Check if the IP of the initial session owner should
#        # match with the current user's IP
#        if ( $IP_MATCH ) {
#            unless ( $self->_ip_matches() ) {
#                $self->delete();
#                $self->flush();
#                return undef;
#            }
#        }

        # Check if the session's expiration ticker is up
        if ( $self->_is_expired() ) {
            $self->delete();
            $self->flush();
#            return undef;
        }

#        # Expring single parameters, if any
#        $self->_expire_params();

#        # Updating last access time for the session
#        $self->{_DATA}->{_SESSION_ATIME} = time();

#        # Marking the session as modified
#        $self->{_STATUS} = MODIFIED;

        return 1;
    }
#    return undef;
    return 1;   #いずれの場合も1を返す
}

######################################################################
##クラス    : CGI::Session::Sweeper::File                           ##
##概要      : CGI::Session::Sweeperサブクラス(driver:File専用)      ##
##          : セッションを列挙する                                  ##
##                                                                  ##
######################################################################
package CGI::Session::Sweeper::File;
our @ISA    = qw(CGI::Session::Sweeper);

#セッション列挙処理
#引数      :なし
#説明      :現在ディスク上に存在するセッションを列挙したHashRefを返す。
#           ※ 各ドライバごとのサブクラスからオーバーロードされる
#戻り値    :{ セッションID => ファイル名 }
sub _scan_sessions {
    
    my $self    = shift;
    my $dir     = $self->{_OPTIONS}[1]{Directory} || '.';
    my $pat     = sprintf( $CGI::Session::File::FileName, '(.+)' );
    
    # ディレクトリオープン
    opendir( DIRH, $dir ) or croak( "can't open directory" );
    
    # 取り込み 再帰はしないものとする
    my %sessions = 
        map { $_->[1] => $_->[0] }
        map { [ /^($pat)/ ] }
                                readdir( DIRH );
    
    # クローズ
    closedir( DIRH );
    
    return \%sessions;
    
}


1;
__END__

なんか、いい加減にちょろっと作ったものですが、Apache/1.3.26+Perl5.6.1(Turbo Linuxだったかな？レンタルサーバなのでよくわかりません)で、順調に動いています。