code/UI_Tag/dump_session.coretag

   1 # Copyright 2002-2007 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7 #
   8 # $Id: dump_session.coretag,v 1.8 2007-03-30 23:40:54 pajamian Exp $
   9
  10 UserTag dump_session Order    name
  11 UserTag dump_session AddAttr
  12 UserTag dump_session Version  $Revision: 1.8 $
  13 UserTag dump_session Routine  <<EOR
  14 sub show_part {
  15         my ($ref, $key) = @_;
  16         return $ref unless $key;
  17         if ($key eq 'SCALAR') {
  18                 my $newref = {};
  19                 foreach my $k (keys %$ref) {
  20                         next if ref $ref->{$k};
  21                         $newref->{$k} = $ref->{$k};
  22                 }
  23                 return $newref;
  24         }
  25         else {
  26                 return { $key, $ref->{$key} };
  27         }
  28 }
  29
  30 sub {
  31         my ($name, $opt) = @_;
  32         my $joiner = $opt->{joiner} || ' ';
  33         return "Cannot dump or find sessions with session type $Vend::Cfg->{SessionType}."
  34                 if ($Vend::Cfg->{SessionType} ne 'File' && $Vend::Cfg->{SessionType} ne 'DBI');
  35
  36
  37         if ($Vend::Cfg->{SessionType} eq 'File') {
  38                 if($opt->{find}) {
  39                         require File::Find;
  40                         my $expire = $Vend::Cfg->{SessionExpire};
  41                         if( int($::Variable->{ACTIVE_SESSION_MINUTES}) ) {
  42                                 $expire = $::Variable->{ACTIVE_SESSION_MINUTES} * 60;
  43                         }
  44                         my $now = time();
  45                         $expire = $now - $expire;
  46                         my @files;
  47                         my $wanted = sub {
  48                                 return unless -f $_;
  49                                 return if (stat(_))[9] < $expire;
  50                                 return if /\.lock$/;
  51                                 push @files, $_;
  52                         };
  53                         File::Find::find($wanted, $Vend::Cfg->{SessionDatabase});
  54                         return join $joiner, @files;
  55                 }
  56                 elsif (! $name) {
  57                         return "dump-session: Nothing to do.";
  58                 }
  59                 else {
  60                         my $fn = Vend::Util::get_filename($name, 2, 1, $Vend::Cfg->{SessionDatabase});
  61                         return '' unless -f $fn;
  62                         my $ref = Vend::Util::eval_file($fn);
  63
  64                         $ref = show_part($ref, $opt->{key}) if $opt->{key};
  65
  66                         my $out = '';
  67                         eval {
  68                                 $out = Vend::Util::uneval($ref);
  69                         };
  70                         return uneval($ref) if $@;
  71                         return $out;
  72                 }
  73         }
  74
  75         if ($Vend::Cfg->{SessionType} eq 'DBI') {
  76                 if($opt->{find}) {
  77                         my $expire = $Vend::Cfg->{SessionExpire};
  78                         if( int($::Variable->{ACTIVE_SESSION_MINUTES}) ) {
  79                                 $expire = $::Variable->{ACTIVE_SESSION_MINUTES} * 60;
  80                         }
  81                         my $now = time();
  82                         $expire = $now - $expire;
  83                         my @sesscodes;
  84
  85                         my $db  = Vend::Data::database_exists_ref($Vend::Cfg->{SessionDB})
  86                                 or return errmsg("Table %s is not available", $Vend::Cfg->{SessionDB});
  87                         my $dbh = $db->dbh();
  88                         my $tname = $db->name();
  89                         my $sql = "select code from $tname where UNIX_TIMESTAMP(last_accessed) >= ?";
  90
  91                         my $sth = $dbh->prepare($sql);
  92                         $sth->execute($expire) || return $DBI::errstr;
  93                         my $code;
  94                         $sth->bind_columns( undef, \$code);
  95
  96                         while($sth->fetch) {
  97                                 push @sesscodes, $code;
  98                         }
  99                         $sth->finish;
 100                         return join $joiner, @sesscodes;
 101                 }
 102                 elsif (! $name) {
 103                         return "dump-session: Nothing to do.";
 104                 }
 105                 else {
 106                         my $db  = Vend::Data::database_exists_ref($Vend::Cfg->{SessionDB})
 107                                 or return errmsg("Table %s is not available", $Vend::Cfg->{SessionDB});
 108                         my $dbh = $db->dbh();
 109                         my $tname = $db->name();
 110                         my $sql = "select session from $tname where code=?";
 111
 112                         my $sth = $dbh->prepare($sql);
 113                         $sth->execute($name);
 114                         my $session;
 115                         $sth->bind_columns( undef, \$session);
 116                         $sth->fetch;
 117                         $sth->finish;
 118
 119                         my $out = '';
 120                         my $ref = Vend::Util::evalr($session);
 121
 122                         ## Allow show of only part
 123                         $ref = show_part($ref, $opt->{key}) if $opt->{key};
 124
 125                         eval {
 126                                 $out = Vend::Util::uneval($ref);
 127                         };
 128                         return uneval($ref) if $@;
 129                         return $out;
 130                 }
 131         }
 132
 133 }
 134 EOR