Data-Session-1.18/0000755000175000017500000000000014012132256012107 5ustar ronronData-Session-1.18/Changelog.ini0000644000175000017500000001702114012132245014476 0ustar ronron[Module] Name=Data::Session Changelog.Creator=Module::Metadata::Changes V 2.12 Changelog.Parser=Config::IniFiles V 3.000003 [V 1.18] Date=2017-08-14T11:13:00 Comments= < 1. Now it's only printed if verbose > 1. - Apart from the above, no other code changes. Just additions to the docs, as follows... - Add important section to the docs, under FAQ: Guidelines re Sources of Confusion. (a) Firstly, explain (with examples) the difference (for CGI::Snapp-derived scripts) between: $self -> param(a_key => 'a_value'); and $self -> param('session') -> param(a_key => 'a_value'); (b) Explain at what stage in a CGI script flush() should be called. (c) Then, explain (with examples) that: $self -> param('session') -> param(a_hash => %a_hash); will fail, and you must use a hashref: $self -> param('session') -> param(a_hash => {%a_hash}); Likewise for arrays 'v' arrayrefs. EOT [V 1.12] Date=2012-04-24T15:13:00 Comments= < 1) is used in Data::Session. EOT [V 1.09] Date=2011-06-17T14:22:00 Comments= < { 'Module::Build' => 0.38 } to Build.PL. - Reformat Build.PL and Makefile.PL now that we've reverted from Padre to Emacs (due to install issues). - Add META.json to files tracked by git. EOT [V 1.04] Date=2011-02-16T11:55:00 Comments= < 1. Now it's only printed if verbose > 1. - Apart from the above, no other code changes. Just additions to the docs, as follows... - Add important section to the docs, under FAQ: Guidelines re Sources of Confusion. (a) Firstly, explain (with examples) the difference (for CGI::Snapp-derived scripts) between: $self -> param(a_key => 'a_value'); and $self -> param('session') -> param(a_key => 'a_value'); (b) Explain at what stage in a CGI script flush() should be called. (c) Then, explain (with examples) that: $self -> param('session') -> param(a_hash => %a_hash); will fail, and you must use a hashref: $self -> param('session') -> param(a_hash => {%a_hash}); Likewise for arrays 'v' arrayrefs. 1.12 2012-04-24T15:13:00 - After prompting by William Bulley (many thanx!) I found a range of issues which have been addressed: - Some combinations of options to new() triggered an unjustifiable die, so code in validate_options() has been simplified. - Add new demos in scripts/: cgi.demo.cgi (CGI script), cgi.sha1.pl (command line script), and file.sha1.pl. - Copy scripts/cgi.demo.cgi into the Synopsis, since such a self-contained CGI demo was lacking. - Copy scripts/file.sha1.pl into the Synopsis, to go with scripts/file.autoincrement.pl. These demonstrate the different uses of file_name and id_file as options to new(). - Clean up some typos within the other demo code in the Synopsis. - Clean up similar typos in scripts/file.autoincrement.pl. - Expand the discussion of how certain options to new() interact. See Combinations of Options. - Fix various typos throughout the PODs. - Switch from Module::Load to Class::Load. - Change the versions of the pre-reqs to correspond to what was available with Perl V 5.10.1. 1.11 2011-07-08T11:17:00 - Replace DBIx::Admin::DSNManager with Config::Tiny, to make it easier to put Data::Session into Debian. - In Build.PL, shift DBIx::Admin::CreateTable from requires to build_requires. Config::Tiny goes there too. - In the test code, change both sleeps from 2 to 3 seconds, to see if that solves rare test failures. - In the test code, use File::Basename's fileparse rather than a regexp to see if the SQLite directory exists. This should fix some test failures under Windows. 1.10 2011-06-21T16:42:00 - After some marvellous debugging by Jeff Lavallee, one of the CPAN testers, I've changed O_RDONLY to O_RDWR in Data::Session::Driver::File, to deal with a flock problem. This code was copied from CGI::Session, which may therefore still have the same problem. - Also, $! is now included in error messages, both in Data::Session::Driver::File and Data::Session::ID::AutoIncrement. Because this reveals directories in paths, $! is only displayed when new(debug => 1) is used in Data::Session. 1.09 2011-06-17T14:22:00 - Revert change in 1.08, which produces errors during global destruction. This means, to save a session, you must store something in it, to force the session to be modified. - Duplicate, briefly, the explanation of sessions and flushing, as the new first point in the FAQ. - Changes some debug messages (relating to session and parameter expiry) which were ambiguous. 1.08 2011-06-17T13:07:00 - Ensure new sessions, and not just modified ones, are written during flush(). 1.07 Mon May 16 9:23:00 2011 - Remove redundant declaration of id() in Data::Session::ID::Static, which was producing the message: field "id" redefined or overridden at ... line 10. 1.06 2011-05-12T12:01:00 - No code changes. - Patch the tests to parse the DSN more closely, to skip tests if the SQLite directory /tmp does not exist. This directory is present in t/basic.ini and t/bulk.ini. 1.05 2011-04-12T13:11:00 - Eliminate references to /tmp by using File::Temp::newdir. This applies to docs and various scripts/*.pl. - Patch t/Test.pm to use DBI. - Patch t/basic.t to avoid a used once error on $BerkeleyDB::Error. - Add configure_requires => { 'Module::Build' => 0.38 } to Build.PL. - Reformat Build.PL and Makefile.PL now that we've reverted from Padre to Emacs (due to install issues). - Add META.json to files tracked by git. 1.04 2011-02-16T11:55:00 - Replace /usr/bin/perl with /usr/bin/env perl. - Replace common::sense with use strict and use warnings, to get uninit var warnings. 1.03 2010-12-24T17:36:00 - Add DBD::SQLite to the list of pre-reqs. - Patch POD warning users to avoid Storable due to this bug: http://rt.cpan.org/Public/Bug/Display.html?id=36087 1.02 2010-12-14T11:16:00 - Change handling of parameters passed to cookie(), so that the caller may pass extra parameters to the query object's cookie() method. - Document the $atime parameter to the atime() method. - Change the POD structure, so that all methods are assigned a level of head2 under a head1 of Methods. - Various small corrections to the POD. 1.01 2010-12-01T16:35:00 - In t/basic.t, use Module::Load to load BerkeleyDB and Cache::Memcache conditionally, and exit cleanly if they are not installed. 1.00 2010-11-30T14:08:00 - Original version.Data-Session-1.18/MANIFEST0000644000175000017500000000271714012132256013247 0ustar ronronChangelog.ini Changes lib/Data/Session.pm lib/Data/Session/Base.pm lib/Data/Session/CGISession.pm lib/Data/Session/Driver.pm lib/Data/Session/Driver/BerkeleyDB.pm lib/Data/Session/Driver/File.pm lib/Data/Session/Driver/Memcached.pm lib/Data/Session/Driver/mysql.pm lib/Data/Session/Driver/ODBC.pm lib/Data/Session/Driver/Oracle.pm lib/Data/Session/Driver/Pg.pm lib/Data/Session/Driver/SQLite.pm lib/Data/Session/ID.pm lib/Data/Session/ID/AutoIncrement.pm lib/Data/Session/ID/MD5.pm lib/Data/Session/ID/SHA1.pm lib/Data/Session/ID/SHA256.pm lib/Data/Session/ID/SHA512.pm lib/Data/Session/ID/Static.pm lib/Data/Session/ID/UUID16.pm lib/Data/Session/ID/UUID34.pm lib/Data/Session/ID/UUID36.pm lib/Data/Session/ID/UUID64.pm lib/Data/Session/Serialize/DataDumper.pm lib/Data/Session/Serialize/FreezeThaw.pm lib/Data/Session/Serialize/JSON.pm lib/Data/Session/Serialize/Storable.pm lib/Data/Session/Serialize/YAML.pm lib/Data/Session/SHA.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP README scripts/berkeleydb.pl scripts/cgi.demo.cgi scripts/cgi.sha1.pl scripts/cookie.pl scripts/digest.pl scripts/expire.pl scripts/file.autoincrement.pl scripts/file.sha1.pl scripts/memcached.pl scripts/sqlite.pl t/00.versions.t t/00.versions.tx t/basic.ini t/basic.t t/bulk.ini t/Test.pm t/traverse.t xt/authors/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Data-Session-1.18/MANIFEST.SKIP0000644000175000017500000000114114012131375014003 0ustar ronron# Avoid version control files. ,v$ \B\.cvsignore$ \B\.git\b \B\.gitignore\b \B\.svn\b \bCVS\b \bRCS\b # Avoid Makemaker generated and utility files. \bblib \bblibdirs$ \bpm_to_blib$ \bMakefile$ \bMakeMaker-\d # Avoid Module::Build generated and utility files. \b_build \bBuild$ \bBuild.bat$ # Avoid Devel::Cover generated files \bcover_db # Avoid temp and backup files. ~$ \#$ \.# \.bak$ \.old$ \.rej$ \.tmp$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid UltraEdit files. \.prj$ \.pui$ ^MYMETA.yml$ ^MYMETA\.json$ ^Data-Session-.* Data-Session-1.18/xt/0000755000175000017500000000000014012132256012542 5ustar ronronData-Session-1.18/xt/authors/0000755000175000017500000000000014012132256014227 5ustar ronronData-Session-1.18/xt/authors/pod.t0000644000175000017500000000020412657730604015210 0ustar ronronuse Test::More; eval "use Test::Pod 1.45"; plan skip_all => "Test::Pod 1.45 required for testing POD" if $@; all_pod_files_ok(); Data-Session-1.18/lib/0000755000175000017500000000000014012132256012655 5ustar ronronData-Session-1.18/lib/Data/0000755000175000017500000000000014012132256013526 5ustar ronronData-Session-1.18/lib/Data/Session.pm0000644000175000017500000020232214012132246015507 0ustar ronronpackage Data::Session; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use Class::Load ':all'; # For try_load_class() and is_class_loaded(). use File::Spec; # For catdir. use File::Slurper 'read_dir'; use Hash::FieldHash ':all'; use Try::Tiny; fieldhash my %my_drivers => 'my_drivers'; fieldhash my %my_id_generators => 'my_id_generators'; fieldhash my %my_serializers => 'my_serializers'; our $errstr = ''; our $VERSION = '1.18'; # ----------------------------------------------- sub atime { my($self, $atime) = @_; my($data) = $self -> session; # This is really only for use by load_session(). if (defined $atime) { $$data{_SESSION_ATIME} = $atime; $self -> session($data); $self -> modified(1); } return $$data{_SESSION_ATIME}; } # End of atime. # ----------------------------------------------- sub check_expiry { my($self) = @_; if ($self -> etime && ( ($self -> atime + $self -> etime) < time) ) { ($self -> verbose) && $self -> log('Expiring id: ' . $self -> id); $self -> delete; $self -> expired(1); } } # End of check_expiry. # ----------------------------------------------- sub clear { my($self, $name) = @_; my($data) = $self -> session; if (! $name) { $name = [$self -> param]; } elsif (ref($name) ne 'ARRAY') { $name = [$name]; } else { $name = [grep{! /^_/} @$name]; } for my $key (@$name) { delete $$data{$key}; delete $$data{_SESSION_PTIME}{$key}; $self -> modified(1); } $self -> session($data); return 1; } # End of clear. # ----------------------------------------------- sub cookie { my($self) = shift; my($q) = $self -> query; my(@param) = ('-name' => $self -> name, '-value' => $self -> id, @_); my($cookie) = ''; if (! $q -> can('cookie') ) { } elsif ($self -> expired) { $cookie = $q -> cookie(@param, -expires => '-1d'); } elsif (my($t) = $self -> expire) { $cookie = $q -> cookie(@param, -expires => "+${t}s"); } else { $cookie = $q -> cookie(@param); } return $cookie; } # End of cookie. # ----------------------------------------------- sub ctime { my($self) = @_; my($data) = $self -> session; return $$data{_SESSION_CTIME}; } # End of ctime. # ----------------------------------------------- sub delete { my($self) = @_; my($result) = $self -> driver_class -> remove($self -> id); $self -> clear; $self -> deleted(1); return $result; } # End of delete. # ----------------------------------------------- sub DESTROY { my($self) = @_; $self -> flush; } # End of DESTROY. # ----------------------------------------------- sub dump { my($self, $heading) = @_; my($data) = $self -> session; ($heading) && $self -> log($heading); for my $key (sort keys %$data) { if (ref($$data{$key}) eq 'HASH') { $self -> log("$key: " . join(', ', map{"$_: $$data{$key}{$_}"} sort keys %{$$data{$key} }) ); } else { $self -> log("$key: $$data{$key}"); } } } # End of dump. # ----------------------------------------------- sub etime { my($self) = @_; my($data) = $self -> session; return $$data{_SESSION_ETIME}; } # End of etime. # ----------------------------------------------- sub expire { my($self, @arg) = @_; if (! @arg) { return $self -> etime; } if ($#arg == 0) { # Set the expiry time of the session. my($data) = $self -> session; my($time) = $self -> validate_time($arg[0]); if ($$data{_SESSION_ETIME} != $time) { $$data{_SESSION_ETIME} = $time; $self -> session($data); $self -> modified(1); } } else { # Set the expiry times of session parameters. my($data) = $self -> session; my($modified) = 0; my(%arg) = @arg; my($time); # Warning: The next line ignores 'each %{@arg}'. while (my($key, $value) = each %arg) { $time = $self -> validate_time($value); ($time == 0) && next; if (! $$data{_SESSION_PTIME}{$key} || ($$data{_SESSION_PTIME}{$key} ne $time) ) { $$data{_SESSION_PTIME}{$key} = $time; $modified = 1; } } if ($modified) { $self -> session($data); $self -> modified(1); } } return 1; } # End of expire. # ----------------------------------------------- sub flush { my($self) = @_; if ($self -> modified && ! $self -> deleted) { $self -> driver_class -> store ( $self -> id, $self -> serializer_class -> freeze($self -> session), $self -> etime ); } ($self -> verbose > 1) && $self -> dump('Flushing. New: ' . $self -> is_new . '. Modified: ' . $self -> modified . '. Deleted: ' . $self -> deleted); return 1; } # End of flush. # ----------------------------------------------- sub get_my_drivers { my($self) = @_; my($path) = $self -> _get_pm_path('Driver'); # Warning: Use sort map{} read_dir, not map{} sort read_dir. But, why? my(@driver) = sort map{s/.pm//; $_} read_dir($path); ($#driver < 0) && die __PACKAGE__ . '. No drivers available'; ($self -> verbose > 1) && $self -> log('Drivers: ' . join(', ', @driver) ); $self -> my_drivers(\@driver); } # End of get_my_drivers. # ----------------------------------------------- sub get_my_id_generators { my($self) = @_; my($path) = $self -> _get_pm_path('ID'); # Warning: Use sort map{} read_dir, not map{} sort read_dir. But, why? my(@id_generator) = sort map{s/.pm//; $_} read_dir($path); ($#id_generator < 0) && die __PACKAGE__ . '. No id generators available'; ($self -> verbose > 1) && $self -> log('Id generators: ' . join(', ', @id_generator) ); $self -> my_id_generators(\@id_generator); } # End of get_my_id_generators. # ----------------------------------------------- sub get_my_serializers { my($self) = @_; my($path) = $self -> _get_pm_path('Serialize'); # Warning: Use sort map{} read_dir, not map{} sort read_dir. But, why? my(@serializer) = sort map{s/.pm//; $_} read_dir($path); ($#serializer < 0) && die __PACKAGE__ . '. No serializers available'; ($self -> verbose > 1) && $self -> log('Serializers: ' . join(', ', @serializer) ); $self -> my_serializers(\@serializer); } # End of get_my_serializers. # ----------------------------------------------- sub _get_pm_path { my($self, $subdir) = @_; my($path) = $INC{'Data/Session.pm'}; $path =~ s/\.pm$//; return File::Spec -> catdir($path, $subdir); } # ----------------------------------------------- sub http_header { my($self) = shift; my($cookie) = $self -> cookie; my($header); if ($cookie) { $header = $self -> query -> header(-cookie => $cookie, @_); } else { $header = $self -> query -> header(@_); } return $header; } # End of http_header. # ----------------------------------------------- sub load_driver { my($self, $arg) = @_; my($class) = join('::', __PACKAGE__, 'Driver', $self -> driver_option); try_load_class($class); die __PACKAGE__ . ". Unable to load class '$class'" if (! is_class_loaded($class) ); ($self -> verbose > 1) && $self -> log("Loaded driver_option: $class"); $self -> driver_class($class -> new(%$arg) ); ($self -> verbose > 1) && $self -> log("Initialized driver_class: $class"); } # End of load_driver. # ----------------------------------------------- sub load_id_generator { my($self, $arg) = @_; my($class) = join('::', __PACKAGE__, 'ID', $self -> id_option); try_load_class($class); die __PACKAGE__ . ". Unable to load class '$class'" if (! is_class_loaded($class) ); ($self -> verbose > 1) && $self -> log("Loaded id_option: $class"); $self -> id_class($class -> new(%$arg) ); ($self -> verbose > 1) && $self -> log("Initialized id_class: $class"); } # End of load_id_generator. # ----------------------------------------------- sub load_param { my($self, $q, $name) = @_; if (! defined $q) { $q = $self -> load_query_class; } my($data) = $self -> session; if (! $name) { $name = [sort keys %$data]; } elsif (ref($name) ne 'ARRAY') { $name = [$name]; } for my $key (grep{! /^_/} @$name) { $q -> param($key => $$data{$key}); } return $q; } # End of load_param. # ----------------------------------------------- sub load_query_class { my($self) = @_; if (! $self -> query) { my($class) = $self -> query_class; try_load_class($class); die __PACKAGE__ . ". Unable to load class '$class'" if (! is_class_loaded($class) ); ($self -> verbose > 1) && $self -> log('Loaded query_class: ' . $class); $self -> query($class -> new); ($self -> verbose > 1) && $self -> log('Called query_class -> new: ' . $class); } return $self -> query; } # End of load_query_class. # ----------------------------------------------- sub load_serializer { my($self, $arg) = @_; my($class) = join('::', __PACKAGE__, 'Serialize', $self -> serializer_option); try_load_class($class); die __PACKAGE__ . ". Unable to load class '$class'" if (! is_class_loaded($class) ); ($self -> verbose > 1) && $self -> log("Loaded serializer_option: $class"); $self -> serializer_class($class -> new(%$arg) ); ($self -> verbose > 1) && $self -> log("Initialized serializer_class: $class"); } # End of load_serializer. # ----------------------------------------------- sub load_session { my($self) = @_; my($id) = $self -> user_id; ($self -> verbose > 1) && $self -> log("Loading session for id: $id"); if ($id) { my($raw_data) = $self -> driver_class -> retrieve($id); ($self -> verbose > 1) && $self -> log("Tried to retrieve session for id: $id. Length of raw data: @{[length($raw_data)]}"); if (! $raw_data) { $self -> new_session($id); } else { # Retrieved an old session, so flag it as accessed, and not-new. my($data) = $self -> serializer_class -> thaw($raw_data); if ($self -> verbose > 1) { for my $key (sort keys %{$$data{_SESSION_PTIME} }) { $self -> log("Recovered session parameter expiry time: $key: $$data{_SESSION_PTIME}{$key}"); } } $self -> id($id); $self -> is_new(0); $self -> session($data); ($self -> verbose > 1) && $self -> dump('Loaded'); # Check for session expiry. $self -> check_expiry; ($self -> verbose > 1) && $self -> dump('Loaded and checked expiry'); # Check for session parameter expiry. # Stockpile keys to be cleared. We can't call $self -> clear($key) inside the loop, # because it updates $$data{_SESSION_PTIME}, which in turns confuses 'each'. my(@stack); while (my($key, $time) = each %{$$data{_SESSION_PTIME} }) { if ($time && ( ($self -> atime + $time) < time) ) { push @stack, $key; } } $self -> clear($_) for @stack; # We can't do this above, just after my($data)..., since it's used just above, as $self -> atime(). $self -> atime(time); ($self -> verbose > 1) && $self -> dump('Loaded and checked parameter expiry'); } } else { $self -> new_session(0); } ($self -> verbose > 1) && $self -> log("Loaded session for id: " . $self -> id); return 1; } # End of load_session. # ----------------------------------------------- sub new { my($class, %arg) = @_; $arg{debug} ||= 0; # new(...). $arg{deleted} = 0; # Internal. $arg{expired} = 0; # Internal. $arg{id} ||= 0; # new(...). $arg{modified} = 0; # Internal. $arg{name} ||= 'CGISESSID'; # new(...). $arg{query} ||= ''; # new(...). $arg{query_class} ||= 'CGI'; # new(...). $arg{session} = {}; # Internal. $arg{type} ||= ''; # new(...). $arg{verbose} ||= 0; # new(...). my($self); try { $self = from_hash(bless({}, $class), \%arg); $self -> get_my_drivers; $self -> get_my_id_generators; $self -> get_my_serializers; $self -> parse_options; $self -> validate_options; $self -> load_driver(\%arg); $self -> load_id_generator(\%arg); $self -> load_serializer(\%arg); $self -> load_session; # Calls user_id() which calls load_query_class() if necessary. } catch { $errstr = $_; $self = undef; }; return $self; } # End of new. # ----------------------------------------------- sub new_session { my($self, $id) = @_; $id = $id ? $id : $self -> id_class -> generate; my($time) = time; $self -> session ({ _SESSION_ATIME => $time, # Access time. _SESSION_CTIME => $time, # Create time. _SESSION_ETIME => 0, # Session expiry time. _SESSION_ID => $id, # Session id. _SESSION_PTIME => {}, # Parameter expiry times. }); $self -> id($id); $self -> is_new(1); } # End of new_session. # ----------------------------------------------- sub param { my($self, @arg) = @_; my($data) = $self -> session; if ($#arg < 0) { return grep{! /^_/} sort keys %$data; } elsif ($#arg == 0) { # If only 1 name is supplied, return the session's data for that name. return $$data{$arg[0]}; } # Otherwise, loop over all the supplied data. my(%arg) = @arg; for my $key (keys %arg) { next if ($key =~ /^_/); # Don't update a value if it's the same as the original value. # That way we don't update the last-access-time. # We're effectively testing $x == $y, but we're not testing to ensure: # o undef == undef # o 0 == 0 # o '' == '' # So changing undef to 0 or visa versa, etc, will all be ignored. (! $$data{$key} && ! $arg{$key}) && next; if ( (! $$data{$key} && $arg{$key}) || ($$data{$key} && ! $arg{$key}) || ($$data{$key} ne $arg{$key}) ) { $$data{$key} = $arg{$key}; $self -> modified(1); } } $self -> session($data); return 1; } # End of param. # ----------------------------------------------- # Format expected: new(type => 'driver:File;id:MD5;serialize:DataDumper'). sub parse_options { my($self) = @_; my($options) = $self -> type || ''; ($self -> verbose > 1) && $self -> log("Parsing type '$options'"); $options =~ tr/ //d; my(%options) = map{split(/:/, $_)} split(/;/, lc $options); # lc! my(%default) = ( driver => 'File', id => 'MD5', serialize => 'DataDumper', ); for my $key (keys %options) { (! $default{$key}) && die __PACKAGE__ . ". Error in type: Unexpected component '$key'"; } my(%driver) = map{(lc $_ => $_)} @{$self -> my_drivers}; my(%id_generator) = map{(lc $_ => $_)} @{$self -> my_id_generators}; my(%serializer) = map{(lc $_ => $_)} @{$self -> my_serializers}; # The sort is just to make the warnings ($required) appear in alphabetical order. for my $required (sort keys %default) { # Set default if user does not supply the key:value pair. if (! exists $options{$required}) { $options{$required} = $default{$required}; ($self -> verbose) && $self -> log("Warning for type: Defaulting '$required' to '$default{$required}'"); } # Ensure the value is set. (! $options{$required}) && die __PACKAGE__ . ". Error in type: Missing value for option '$required'"; # Ensure the case of the value is correct. if ($required eq 'driver') { if ($driver{lc $options{$required} }) { $options{$required} = $driver{lc $options{$required} }; } else { die __PACKAGE__ . ". Unknown driver '$options{$required}'"; } } elsif ($required eq 'id') { if ($id_generator{lc $options{$required} }) { $options{$required} = $id_generator{lc $options{$required} }; } else { die __PACKAGE__ . ". Unknown id generator '$options{$required}'"; } } elsif ($required eq 'serialize') { if ($serializer{lc $options{$required} }) { $options{$required} = $serializer{lc $options{$required} }; } else { die __PACKAGE__ . ". Unknown serialize '$options{$required}'"; } } } $self -> driver_option($options{driver}); $self -> id_option($options{id}); $self -> serializer_option($options{serialize}); $self -> type(join(';', map{"$_:$options{$_}"} sort keys %default)); if ($self -> verbose > 1) { $self -> log('type: ' . $self -> type); $self -> log('driver_option: ' . $self -> driver_option); $self -> log('id_option: ' . $self -> id_option); $self -> log('serializer_option: ' . $self -> serializer_option); } } # End of parse_options. # ----------------------------------------------- # Warning: Returns a hashref. sub ptime { my($self) = @_; my($data) = $self -> session; return $$data{_SESSION_PTIME}; } # End of ptime. # ----------------------------------------------- sub save_param { my($self, $q, $name) = @_; if (! defined $q) { $q = $self -> load_query_class; } my($data) = $self -> session; if (! $name) { $name = [$q -> param]; } elsif (ref($name) ne 'ARRAY') { $name = [grep{! /^_/} $name]; } else { $name = [grep{! /^_/} @$name]; } for my $key (@$name) { $$data{$key} = $q -> param($key); $self -> modified(1); } $self -> session($data); return 1; } # End of save_param. # ----------------------------------------------- sub traverse { my($self, $sub) = @_; return $self -> driver_class -> traverse($sub); } # End of traverse. # ----------------------------------------------- sub user_id { my($self) = @_; # Sources of id: # o User supplied one in $session -> new(id => $id). # o User didn't, so we try $self -> query -> cookie and/or $self -> query -> param. my($id) = $self -> id; if (! $id) { $self -> load_query_class; my($name) = $self -> name; my($q) = $self -> query; if ($q -> can('cookie') ) { $id = $q -> cookie($name) || $q -> param($name); ($self -> verbose > 1) && $self -> log('query can cookie(). id from cookie or param: ' . ($id || '') ); } else { $id = $q -> param($name); ($self -> verbose > 1) && $self -> log("query can't cookie(). id from param: " . ($id || '') ); } if (! $id) { $id = 0; } } return $id; } # End of user_id. # ----------------------------------------------- sub validate_options { my($self) = @_; if ( ($self -> id_option eq 'Static') && ! $self -> id) { die __PACKAGE__ . '. When using id:Static, you must provide a (true) id to new(id => ...)'; } } # End of validate_options. # ----------------------------------------------- sub validate_time { my($self, $time) = @_; (! $time) && return 0; $time = "${time}s" if ($time =~ /\d$/); ($time !~ /^([-+]?\d+)([smhdwMy])$/) && die __PACKAGE__ . ". Can't parse time: $time"; my(%scale) = ( s => 1, m => 60, h => 3600, d => 86400, w => 604800, M => 2592000, y => 31536000, ); return $scale{$2} * $1; } # End of validate_time. # ----------------------------------------------- 1; =pod =head1 NAME Data::Session - Persistent session data management =head1 Synopsis 1: A self-contained CGI script (scripts/cgi.demo.cgi): #!/usr/bin/perl use CGI; use Data::Session; use File::Spec; # ---------------------------------------------- sub generate_html { my($name, $id, $count) = @_; $id ||= ''; my($title) = "CGI demo for Data::Session"; return < $title Number of times this script has been run: $count.
Current value of $name: $id.
EOS } # End of generate_html. # ---------------------------------------------- my($q) = CGI -> new; my($name) = 'sid'; # CGI form field name. my($sid) = $q -> param($name); my($dir_name) = '/tmp'; my($type) = 'driver:File;id:MD5;serialize:JSON'; my($session) = Data::Session -> new ( directory => $dir_name, name => $name, query => $q, type => $type, ); my($id) = $session -> id; # First entry ever? my($count); if ($sid) # Not $id, which always has a value... { # No. The CGI form field called sid has a (true) value. # So, this is the code for the second and subsequent entries. # Count the # of times this CGI script has been run. $count = $session -> param('count') + 1; } else { # Yes. There is no CGI form field called sid (with a true value). # So, this is the code for the first entry ever. # Count the # of times this CGI script has been run. $count = 0; } $session -> param(count => $count); print $q -> header, generate_html($name, $id, $count); # Calling flush() is good practice, rather than hoping 'things just work'. # In a persistent environment, this call is mandatory... # But you knew that, because you'd read the docs, right? $session -> flush; 2: A basic session. See scripts/sqlite.pl: # The EXLOCK is for BSD-based systems. my($directory) = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); my($data_source) = 'dbi:SQLite:dbname=' . File::Spec -> catdir($directory, 'sessions.sqlite'); my($type) = 'driver:SQLite;id:SHA1;serialize:DataDumper'; # Case-sensitive. my($session) = Data::Session -> new ( data_source => $data_source, type => $type, ) || die $Data::Session::errstr; 3: Using BerkeleyDB as a cache manager. See scripts/berkeleydb.pl: # The EXLOCK is for BSD-based systems. my($file_name) = File::Temp -> new(EXLOCK => 0, SUFFIX => '.bdb'); my($env) = BerkeleyDB::Env -> new ( Home => File::Spec -> tmpdir, Flags => DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL, ); if (! $env) { print "BerkeleyDB is not responding. \n"; exit; } my($bdb) = BerkeleyDB::Hash -> new(Env => $env, Filename => $file_name, Flags => DB_CREATE); if (! $bdb) { print "BerkeleyDB is not responding. \n"; exit; } my($type) = 'driver:BerkeleyDB;id:SHA1;serialize:DataDumper'; # Case-sensitive. my($session) = Data::Session -> new ( cache => $bdb, type => $type, ) || die $Data::Session::errstr; 4: Using memcached as a cache manager. See scripts/memcached.pl: my($memd) = Cache::Memcached -> new ({ namespace => 'data.session.id', servers => ['127.0.0.1:11211'], }); my($test) = $memd -> set(time => time); if (! $test || ($test != 1) ) { print "memcached is not responding. \n"; exit; } $memd -> delete('time'); my($type) = 'driver:Memcached;id:SHA1;serialize:DataDumper'; # Case-sensitive. my($session) = Data::Session -> new ( cache => $memd, type => $type, ) || die $Data::Session::errstr; 5: Using a file to hold the ids. See scripts/file.autoincrement.pl: # The EXLOCK is for BSD-based systems. my($directory) = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); my($file_name) = 'autoinc.session.dat'; my($id_file) = File::Spec -> catfile($directory, $file_name); my($type) = 'driver:File;id:AutoIncrement;serialize:DataDumper'; # Case-sensitive. my($session) = Data::Session -> new ( id_base => 99, id_file => $id_file, id_step => 2, type => $type, ) || die $Data::Session::errstr; 6: Using a file to hold the ids. See scripts/file.sha1.pl (non-CGI context): my($directory) = '/tmp'; my($file_name) = 'session.%s.dat'; my($type) = 'driver:File;id:SHA1;serialize:DataDumper'; # Case-sensitive. # Create the session: my($session) = Data::Session -> new ( directory => $directory, file_name => $file_name, type => $type, ) || die $Data::Session::errstr; # Time passes... # Retrieve the session: my($id) = $session -> id; my($session) = Data::Session -> new ( directory => $directory, file_name => $file_name, id => $id, # <== Look! You must supply the id for retrieval. type => $type, ) || die $Data::Session::errstr; 7: As a variation on the above, see scripts/cgi.sha1.pl (CGI context but command line program): # As above (scripts/file.sha1.pl), for creating the session. Then... # Retrieve the session: my($q) = CGI -> new; # CGI form data provides the id. my($session) = Data::Session -> new ( directory => $directory, file_name => $file_name, query => $q, # <== Look! You must supply the id for retrieval. type => $type, ) || die $Data::Session::errstr; Also, much can be gleaned from t/basic.t and t/Test.pm. See L. =head1 Description L is typically used by a CGI script to preserve state data between runs of the script. This gives the end user the illusion that the script never exits. It can also be used to communicate between 2 scripts, as long as they agree beforehand what session id to use. See L for an extended discussion of the design changes between L and L. L stores user data internally in a hashref, and the module reserves key names starting with '_'. The current list of reserved keys is documented under L. Of course, the module also has a whole set of methods to help manage state. =head1 Methods =head2 new() Calling new() returns a object of type L, or - if new() fails - it returns undef. For details see L. new() takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. But a warning: In some cases, setting them after this module has used the previous value, will have no effect. All such cases should be documented. Beginners understandably confused by the quantity of options should consult the L for example code. The questions of combinations of options, and which option has priority over other options, are addressed in the section, L. =over 4 =item o cache => $cache Specifies an object of type L or L to use for storage. Only needed if you use 'type' like 'driver:BerkeleyDB ...' or 'driver:Memcached ...'. See L and L. Default: '' (the empty string). =item o data_col_name => $string Specifies the name of the column holding the session data, in the session table. This key is optional. Default: 'a_session'. =item o data_source => $string Specifies a value to use as the 1st parameter in the call to L's connect() method. A typical value would be 'dbi:Pg:dbname=project'. This key is optional. It is only used if you do not supply a value for the 'dbh' key. Default: '' (the empty string). =item o data_source_attrs => $hashref Specify a hashref of options to use as the last parameter in the call to L's connect() method. This key is optional. It is only used if you do not supply a value for the 'dbh' key. Default: {AutoCommit => 1, PrintError => 0, RaiseError => 1}. =item o dbh => $dbh Specifies a database handle to use to access the session table. This key is optional. However, if not specified, you must specify a value for 'data_source', and perhaps also 'username' and 'password', so that this module can create a database handle. If this module does create a database handle, it will also destroy it, whereas if you supply a database handle, you are responsible for destroying it. =item o debug => $Boolean Specifies that debugging should be turned on (1) or off (0) in L and L. When debug is 1, $! is included in error messages, but because this reveals directory names, it is 0 by default. This key is optional. Default: 0. =item o directory => $string Specifies the directory in which session files are stored, when each session is stored in a separate file (by using 'driver:File ...' as the first component of the 'type'). This key is optional. Default: Your temp directory as determined by L. See L for details. =item o file_name => $string_containing_%s Specifies the syntax for the names of session files, when each session is stored in a separate file (by using 'driver:File ...' as the first component of the 'type'). This key is optional. Default: 'cgisess_%s', where the %s is replaced at run-time by the session id. The directory in which these files are stored is specified by the 'directory' option above. See L for details. =item o host => $string Specifies a host, typically for use with a data_source referring to MySQL. This key is optional. Default: '' (the empty string). =item o id => $string Specifies an id to retrieve from storage. This key is optional. Default: 0. Note: If you do not provide an id here, the module calls L to determine whether or not an id is available from a cookie or a form field. This complex topic is discussed in the section L. =item o id_col_name => $string Specifies the name of the column holding the session id, in the session table. This key is optional. Default: 'id'. =item o id_base => $integer Specifies the base from which to start ids when using the '... id:AutoIncrement ...' component in the 'type'. Note: The first id returned by L will be id_base + id_step. So, if id_base is 1000 and id_step is 10, then the lowest id will be 1010. This key is optional. Default: 0. =item o id_file => $file_path_and_name Specifies the file path and name in which to store the last used id, as calculated from C, when using the '... id:AutoIncrement ...' component in the 'type'. This value must contain a path because the 'directory' option above is only used for session files (when using L). This key is optional. Default: File::Spec -> catdir(File::Spec -> tmpdir, 'data.session.id'). =item o id_step => $integer Specifies the step size between ids when using the '... id:AutoIncrement ...' component of the 'type'. This key is optional. Default: 1. =item o name => $string Specifies the name of the cookie or form field which holds the session id. This key is optional. Default: 'CGISESSID'. Usage of 'name' is discussed in the sections L and L. =item o no_flock => $boolean Specifies (no_flock => 1) to not use flock() to obtain a lock on a session file before processing it, or (no_flock => 0) to use flock(). This key is optional. Default: 0. This value is used in these cases: =over 4 =item o type => 'driver:File ...' =item o type => '... id:AutoIncrement ...' =back =item o no_follow => $boolean Influences the mode to use when calling sysopen() on session files. 'Influences' means the value is bit-wise ored with O_RDWR for reading and with O_WRONLY for writing. This key is optional. Default: eval { O_NOFOLLOW } || 0. This value is used in this case: =over 4 =item o type => 'driver:File ...' =back =item o password => $string Specifies a value to use as the 3rd parameter in the call to L's connect() method. This key is optional. It is only used if you do not supply a value for the 'dbh' key. Default: '' (the empty string). =item o pg_bytea => $boolean Specifies that you're using a Postgres-specific column type of 'bytea' to hold the session data, in the session table. This key is optional, but see the section, L for how it interacts with the pg_text key. Default: 0. Warning: Columns of type bytea can hold null characters (\x00), whereas columns of type text cannot. =item o pg_text => $boolean Specifies that you're using a Postgres-specific column type of 'text' to hold the session data, in the session table. This key is optional, but see the section, L for how it interacts with the pg_bytea key. Default: 0. Warning: Columns of type bytea can hold null characters (\x00), whereas columns of type text cannot. =item o port => $string Specifies a port, typically for use with a data_source referring to MySQL. This key is optional. Default: '' (the empty string). =item o query => $q Specifies the query object. If not specified, the next option - 'query_class' - will be used to create a query object. Either way, the object will be accessible via the $session -> query() method. This key is optional. Default: '' (the empty string). =item o query_class => $class_name Specifies the class of query object to create if a value is not provided for the 'query' option. This key is optional. Default: 'CGI'. =item o socket => $string Specifies a socket, typically for use with a data_source referring to MySQL. The reason this key is called socket and not mysql_socket is in case other drivers permit a socket option. This key is optional. Default: '' (the empty string). =item o table_name => $string Specifies the name of the table holding the session data. This key is optional. Default: 'sessions'. =item o type => $string Specifies the type of L object you wish to create. This key is optional. Default: 'driver:File;id:MD5;serialize:DataDumper'. This complex topic is discussed in the section L. =item o umask => $octal_number Specifies the mode to use when calling sysopen() on session files. This value is used in these cases: =over 4 =item o type => 'driver:File ...' =item o type => '... id:AutoIncrement ...' =back Default: 0660 (octal). =item o username => $string Specifies a value to use as the 2nd parameter in the call to L's connect() method. This key is optional. It is only used if you do not supply a value for the 'dbh' key. Default: '' (the empty string). =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is optional. Default: 0, meaings nothing is printed. See L for what happens when verbose is 2. =back =head3 Specifying Session Options See also L. The default 'type' string is 'driver:File;id:MD5;serialize:DataDumper'. It consists of 3 optional components separated by semi-colons. Each of those 3 components consists of 2 fields (a key and a value) separated by a colon. The keys: =over 4 =item o driver This specifies what type of persistent storage you wish to use for session data. Values for 'driver': =over 4 =item o BerkeleyDB Use L for storage. In this case, you must pass an object of type L to new() as the value of the 'cache' option. See L. =item o File The default, 'File', says sessions are each stored in a separate file. The directory for these files is specified with the 'directory' option to new(). If a directory is not specified in that way, L is used to find your temp directory. The names of the session files are generated from the 'file_name' option to new(). The default file name (pattern) is 'cgisess_%s', where the %s is replaced by the session id. See L. =item o Memcached Use C for storage. In this case, you must pass an object of type L to new() as the value of the 'cache' option. See L. =item o mysql This says each session is stored in a separate row of a database table using the L database server. These rows have a unique primary id equal to the session id. See L. =item o ODBC This says each session is stored in a separate row of a database table using the L database connector. These rows have a unique primary id equal to the session id. See L. =item o Oracle This says each session is stored in a separate row of a database table using the L database server. These rows have a unique primary id equal to the session id. See L. =item o Pg This says each session is stored in a separate row of a database table using the L database server. These rows have a unique primary id equal to the session id. See L. =item o SQLite This says each session is stored in a separate row of a database table using the SQLite database server. These rows have a unique primary id equal to the session id. The advantage of SQLite is that a client I are shipped with all recent versions of Perl. See L. =back =item o id This specifies what type of id generator you wish to use. Values for 'id': =over 4 =item o AutoIncrement This says ids are generated starting from a value specified with the 'id_base' option to new(), and the last-used id is stored in the file name given by the 'id_file' option to new(). This file name must include a path, since the 'directory' option to new() is I used here. When a new id is required, the value in the file is incremented by the value of the 'id_step' option to new(), with the new value both written back to the file and returned as the new session id. The default value of id_base is 0, and the default value of id_step is 1. Together, the first id available as a session id is id_base + id_step = 1. The sequence starts when the module cannot find the given file, or when its contents are not numeric. See L. =item o MD5 The default, 'MD5', says ids are to be generated by L. See L. =item o SHA1 This says ids are to be generated by L, using a digest algorithm of 1. See L. =item o SHA256 This says ids are to be generated by L, using a digest algorithm of 256. See L. =item o SHA512 This says ids are to be generated by L, using a digest algorithm of 512. See L. =item o Static This says that the id passed in to new(), as the value of the 'id' option, will be used as the session id for every session. Of course, this id must have a true value. L dies on all values Perl regards as false. See L. =item o UUID16 This says ids are to be generated by L, to generate a 16 byte long binary UUID. See L. =item o UUID34 This says ids are to be generated by L, to generate a 34 byte long string UUID. See L. =item o UUID36 This says ids are to be generated by L, to generate a 36 byte long string UUID. See L. =item o UUID64 This says ids are to be generated by L, to generate a 24 (sic) byte long, base-64 encoded, UUID. See L. =back See scripts/digest.pl which prints the length of each type of digest. =item o serialize The specifies what type of mechanism you wish to use to convert the in-memory session data into a form appropriate for your chosen storage type. Values for 'serialize': =over 4 =item o DataDumper Use L to freeze/thaw sessions. See L. =item o FreezeThaw Use L to freeze/thaw sessions. See L. =item o JSON Use L to freeze/thaw sessions. See L. =item o Storable Use L to freeze/thaw sessions. See L. Warning: Storable should be avoided until this problem is fixed: L. =item o YAML Use L to freeze/thaw sessions. See L. =back =back =head3 Case-sensitive Options Just to emphasize: The names of drivers, etc follow the DBD::* (or similar) style of case-sensitivity. The following classes for drivers, id generators and serializers, are shipped with this package. Drivers: =over 4 =item o L This name comes from L. And yes, the module uses L and not L. =item o L =item o L This name comes from L even though the external program you run is called memcached. =item o L =item o L =item o L =item o L =item o L =back ID generators: =over 4 =item o L =item o L =item o L =item o L =item o L =item o L =item o L =item o L =item o L =item o L =back Serializers: =over 4 =item o L =item o L =item o L =item o L Warning: Storable should be avoided until this problem is fixed: L =item o L =back =head3 Specifying an Id L is called to determine if an id is available from a cookie or a form field. There are several cases to consider: =over 4 =item o You specify an id which exists in storage You can check this with the call $session -> is_new, which will return 0. $session -> id will return the old id. =item o You do not specify an id The module generates a new session and a new id. You can check this with the call $session -> is_new, which will return 1. $session -> id will return the new id. =item o You specify an id which does not exist in storage You can check this with the call $session -> is_new, which will return 1. $session -> id will return the old id. =back So, how to tell the difference between the last 2 cases? Like this: if ($session -> id == $session -> user_id) { # New session using user-supplied id. } else { # New session with new id. } =head3 Combinations of Options See also L, for options-related combinations. =over 4 =item o dbh If you don't specify a value for the 'dbh' key, this module must create a database handle in those cases when you specify a database driver of some sort in the value for 'type'. To create that handle, we needs a value for 'data_source', and that in turn may require values for 'username' and 'password'. When using SQLite, just specify a value for 'data_source'. The default values for 'username' and 'password' - empty strings - will work. =item o file_name and id_file When using new(type => 'driver:File;id:AutoIncrement;...'), then file_name is ignored and id_file is used. If id_file is not supplied, it defaults to File::Spec -> catdir(File::Spec -> tmpdir, 'data.session.id'). When using new(type => 'driver:File;id:;...'), then id_file is ignored and file_name is used. If file_name is not supplied, it defaults to 'cgisess_%s'. Note the mandatory %s. =item o pg_bytea and pg_text If you set 'pg_bytea' to 1, then 'pg_text' will be set to 0. If you set 'pg_text' to 1, then 'pg_bytea' will be set to 0. If you set them both to 0 (i.e. the default), then 'pg_bytea' will be set to 1. If you set them both to 1, 'pg_bytea' will be left as 1 and 'pg_text' will be set to 0. This choice was made because you really should be using a column type of 'bytea' for a_session in the sessions table, since the type 'text' does not handle null (\x00) characters. =back =head2 atime([$atime]) The [] indicates an optional parameter. Returns the last access time of the session. By default, the value comes from calling Perl's time() function, or you may pass in a time, which is then used to set the last access time of the session. This latter alternative is used by L. See also L, L and L. =head2 check_expiry() Checks that there is an expiry time set for the session, and, if (atime + etime) < time(): =over 4 =item o Deletes the session See L for precisely what this means. =item o Sets the expired flag See L. =back This is used when the session is loaded, when you call L, and by scripts/expire.pl. =head2 clear([$name]) The [] indicates an optional parameter. Returns 1. Specifies that you wish to delete parameters stored in the session, i.e. stored by previous calls to param(). $name is a parameter name or an arrayref of parameter names. If $name is not specified, it is set to the list of all unreserved keys (parameter names) in the session. See L for details. =head2 cookie([@arg]) The [] indicates an optional parameter. Returns a cookie, or '' (the empty string) if the query object does not have a cookie() method. Use the @arg parameter to pass any extra parameters to the query object's cookie() method. Warning: Parameters which are handled by L, and hence should I be passed in, are: =over 4 =item o -expires =item o -name =item o -value =back See L and scripts/cookie.pl. =head2 ctime() Returns the creation time of the session. The value comes from calling Perl's time() function when the session was created. This is not the creation time of the session I, except for new sessions. See also L, L and L. =head2 delete() Returns the result of calling the driver's remove() method. Specifies that you want to delete the session. Here's what it does: =over 4 =item o Immediately deletes the session from storage =item o Calls clear() This deletes all non-reserved parameters from the session object, and marks it as modified. =item o Marks the session object as deleted =back The latter step means that when (or if) the session object goes out of scope, it will not be flushed to storage. Likewise, if you call flush(), the call will be ignored. Nevertheless, the session object is still fully functional - it just can't be saved or retrieved. See also L and L. =head2 deleted() Returns a Boolean (0/1) indicating whether or not the session has been deleted. See also L and L. =head2 dump([$heading]) The [] indicates an optional parameter. Dumps the session's contents to STDERR, with a prefix of '# '. The $heading, if any, is written first, on a line by itself, with the same prefix. This is especially useful for testing, since it fits in with the L method diag(). When verbose is 2, dump is called at these times: =over 4 =item o When a session is flushed =item o As soon as a session is loaded =item o As soon as expiry is checked on a just-loaded session =item o As soon as parameter expiry is checked on a just-loaded session =back =head2 etime() Returns the expiry time of the session. This is the same as calling $session -> expiry(). In fact, this just calls $session -> etime. See also L, L and L. =head2 expire([@arg]) The [] indicates an optional parameter. Specifies that you wish to set or retrieve the session's expiry time, or set the expiry times of session parameters. Integer time values ($time below) are assumed to be seconds. The value may be positive or 0 or negative. These expiry times are relative to the session's last access time, not the session's creation time. In all cases, a time of 0 disables expiry. This affects users of L. See below and L. When a session expires, it is deleted from storage. See L for details. The test for whether or not a session has expired only takes place when a session is loaded from storage. When a session parameter expires, it is deleted from the session object. See L for details. The test for whether or not a session parameter has expired only takes place when a session is loaded from storage. =over 4 =item o $session -> expire() Use $session -> expire() to return the session's expiry time. This just calls $session -> etime. The default expiry time is 0, meaning the session will never expire. Likewise, by default, session parameters never expire. =item o $session -> expire($time) Use $session -> expire($time) to set the session's expiry time. Use these suffixes to change the interpretation of the integer you specify: +-----------+---------------+ | Suffix | Meaning | +-----------+---------------+ | s | Second | | m | Minute | | h | Hour | | d | Day | | w | Week | | M | Month | | y | Year | +-----------+---------------+ Hence $session -> expire('2h') means expire the session in 2 hours. expire($time) calls validate_time($time) to perform the conversion from '2h' to seconds, so L is available to you too. If setting a time like this, expire($time) returns 1. Note: The time set here is passed as the 3rd parameter to the storage driver's store() method (for all types of storage), and from there as the 3rd parameter to the set() method of L. Of course, this doesn't happen immediately - it only happens when the session is saved. =item o $session -> expire($key_1 => $time_1[, $key_2 => $time_2...]) Use $session -> expire($key_1 => $time_1[, $key_2 => $time_2...]) to set the expiry times of session parameters. =back Special cases: =over 4 =item o To expire the session immediately, call delete() =item o To expire a session parameter immediately, call clear($key) =back See also L, L, L, L and L. =head2 expired() Returns a Boolean (0/1) indicating whether or not the session has expired. See L. =head2 flush() Returns 1. Specifies that you want the session object immediately written to storage. If you have previously called delete(), the call to flush() is ignored. If the object has not been modified, the call to flush() is ignored. Warning: With persistent environments, you object may never go out of scope that way you think it does.See L for details. These reserved session parameters are included in what's written to storage: =over 4 =item o _SESSION_ATIME The session's last access time. =item o _SESSION_CTIME The session's creation time. =item o _SESSION_ETIME The session's expiry time. A time of 0 means there is no expiry time. This affect users of L. See L and L. =item o _SESSION_ID The session's id. =item o _SESSION_PTIME A hashref of session parameter expiry times. =back =head2 http_header([@arg]) The [] indicate an optional parameter. Returns a HTTP header. This means it does I print the header. You have to do that, when appropriate. Unlike L, L does I force the document type to be 'text/html'. You must pass in a document type to http_header(), as C<< $session -> http_header('-type' => 'text/html') >>, or use the query object's default. Both L and L default to 'text/html'. L handles the case where the query object does not have a cookie() method, by calling $session -> cookie() to generate either a cookie, or '' (the empty string). The @arg parameter, if any, is passed to the query object's header() method, after the cookie parameter, if any. =head2 id() Returns the id of the session. =head2 is_new() Returns a Boolean (0/1). Specifies you want to know if the session object was created from scratch (1) or was retrieved from storage (0). =head2 load_param([$q][, $name]) The [] indicate optional parameters. Returns $q. Loads (copies) all non-reserved parameters from the session object into the query object. L performs the opposite operation. $q is a query object, and $name is a parameter name or an arrayref of names. If the query object is not specified, generates one by calling $session -> load_query_class, and stores it in the internal 'query' attribute. If you don't provide $q, use undef, don't just omit the parameter. If $name is specified, only the session parameters named in the arrayref are processed. If $name is not specified, copies all parameters belonging to the query object. =head2 load_query_class() Returns the query object. This calls $session -> query_class -> new if the session object's query object is not defined. =head2 load_session() Returns a session. Note: This method does not take any parameters, and hence does not function in the same way as load(...) in L. Algorithm: =over 4 =item o If user_id() returns a session id, try to load that session If that succeeds, return the session. If it fails, generate a new session, and return it. You can call is_new() to tell the difference between these 2 cases. =item o If user_id() returns 0, generate a new session, and return it =back =head2 modified() Returns a Boolean (0/1) indicating whether or not the session's parameters have been modified. However, changing a value from one form of not-defined, e.g. undef, to another form of not-defined, e.g. 0, is ignored, meaning the modified flag is not set. In such cases, you could set the flag yourself. Note: Loading a session from storage changes the session's last access time, which means the session has been modified. If you wish to stop the session being written to storage, without deleting it, you can reset the modified flag with $session -> modified(0). =head2 param([@arg]) The [] indicates an optional parameter. Specifies that you wish to retrieve data stored in the session, or you wish to store data in the session. Data is stored in the session object as in a hash, via a set of $key => $value relationships. Use $session -> param($key_1 => $value_1[, $key_2 => $value_2...]) to store data in the session. If storing data, param() returns 1. The values stored in the session may be undef. Note: If the value being stored is the same as the pre-existing value, the value in the session is not updated, which means the last access time does not change. Use $session -> param() to return a sorted list of all keys. That call returns a list of the keys you have previously stored in the session. Use $session -> param('key') to return the value associated with the given key. See also L. =head2 ptime() Returns the hashref of session parameter expiry times. Keys are parameter names and values are expiry times in seconds. These expiry times are set by calling L. See also L, L and L. =head2 save_param([$q][, $name]) The [] indicate optional parameters. Returns 1. Loads (copies) all non-reserved parameters from the query object into the session object. L performs the opposite operation. $q is a query object, and $name is a parameter name or an arrayref of names. If the query object is not specified, generates one by calling $session -> load_query_class, and stores it in the internal 'query' attribute. This means you can retrieve it with $session -> query. If you don't provide $q, use undef, don't just omit the parameter. If $name is specified, only the session parameters named in the arrayref are processed. If $name is not specified, copies all parameters. =head2 traverse($sub) Returns 1. Specifies that you want the $sub called for each session id found in storage, with one (1) id as the only parameter in each call. Note: traverse($sub) does not load the sessions, and hence has no effect on the session's last access time. See scripts/expire.pl. =head2 user_id() Returns either a session id, or 0. Algorithm: =over 4 =item o If $session -> id() returns a true value, return that E.g. The user supplied one in $session -> new(id => $id). Return this id. =item o Try to recover an id from the cookie object or the query object. If the query object supports the cookie method, call $self -> query -> cookie and (if that doesn't find an id), $self -> query -> param. If the query object does not support the cookie method, just call $self -> query -> param. Return any id found, or 0. Note: The name of the cookie, and the name of the CGI form field, is passed to new() by the 'name' option. =back =head2 validate_options() Cross-check a few things. E.g. When using type => '... id:Static ...', you must supply a (true) id to new(id => ...'). =head2 validate_time($time) Dies for an invalid time string, or returns the number of seconds corresponding to $time, which may be positive or negative. See L for details on the time string format. =head1 Test Code t/basic.ini and t/bulk.ini contain DSNs for BerkeleyDB, File, Memcache, MySQL, Pg and SQLite. Actually, they're the same file, just with different DSNs activated. So, you can use t/basic.t to run minimal tests (with only File and SQLite activated) like this: perl -Ilib t/basic.t or you can edit t/bulk.ini as desired, and pass it in like this: perl -Ilib t/basic.t t/bulk.ini Simple instructions for installing L (Oracle and Perl) are in L. Simple instructions for installing L and memcached are in L. =head1 FAQ =head2 Guidelines re Sources of Confusion This section discusses various issues which confront beginners: =over 4 =item o 1: Both Data::Session and L have a I method Let's say your L script sub-classes L or it's successor L. Then inside your sub-class's methods, this works: $self -> param(a_key => 'a_value'); Time passes... my($value) = $self -> param('a_key'); because those 2 modules each implement a method called I. Basically, you're storing a value (via 'param') inside $self. But when you store an object of type Data::Session using I, it looks like this: $self -> param(session => Data::Session -> new(...) ); Now, Data::Session itself I implements a method called I. So, to store something in the session (but not in $self), you must do: $self -> param('session') -> param(a_key => 'a_value'); Time passes... my($value) = $self -> param('session') -> param('a_key'); It should be obvious that confusion can arise here because the 2 objects represented by $self and $self -> param('session') both have I methods. =item o 2: How exactly should a L script save a session? The first example in the Synopsis shows a very simple L script doing the right thing by calling I just before it exits. Alternately, if you sub-class L, the call to I is best placed in your I method, which is where you override L. The point here is that your I is called automatically at the end of each run mode. This important matter is also discussed in L below. =item o 3: Storing array and hashes Put simply: Don't do that! This will fail: $self -> param('session') -> param(my_hash => %my_hash); Time passes... my(%my_hash) = $self -> param('session') -> param('my_hash'); Likewise for an array instead of a hash. But why? Because the part 'param(my_hash => %my_hash)' is basically assigning a list (%my_hash) to a scalar (my_hash). Hence, only 1 element of the list (the 'first' key in some unknown order) will be assigned. So, when you try to restore the hash with 'my(%my_hash) ...', all you'll get back is a scalar, which will generate the classic error message 'Odd number of elements in hash assignment...'. The solution is to use arrayrefs and hashrefs: $self -> param('session') -> param(my_hash => {%my_hash}); Time passes... my(%my_hash) = %{$self -> param('session') -> param('my_hash')}; Likewise for an array: $self -> param('session') -> param(my_ara => [@my_ara]); Time passes... my(@my_ara) = @{$self -> param('session') -> param('my_ara')}; =back =head2 General Questions =over 4 =item o My sessions are not getting written to disk! This is because you haven't stored anything in them. You're probably thinking sessions are saved just because they exist. Actually, sessions are only saved if they have at least 1 parameter set. The session id and access/etc times are not enough to trigger saving. Just do something like $session -> param(ok => 1); if you want a session saved just to indicate it exists. Code like this sets the modified flag on the session, so that flush() actually does the save. Also, see L, below, to understand why flush() must be called explicitly in persistent environments. =item o Why don't the test scripts use L? I decided to circumvent it by using L and adopting the wonders of nested testing. But, since V 1.11, I've replaced that module with L, to reduce dependencies, and hence to make it easier to get L into Debian. See t/basic.t, and in particular this line: subtest $driver => sub. =item o Why didn't you use OSSP::uuid as did L? Because when I tried to build that module (under Debian), ./configure died, saying I had set 2 incompatible options, even though I hadn't set either of them. =item o What happens when 2 processes write sessions with the same id? The last-to-write wins, by overwriting what the first wrote. =item o Params::Validate be adopted to validate parameters? Not yet. =back =head1 Troubleshooting =head2 Trouble with Errors When object construction fails, new() sets $Data::Session::errstr and returns undef. This means you can use this idiom: my($session) = Data::Session -> new(...) || process_error($Data::Session::errstr); However, when methods detect errors they die, so after successful object construction, you can do: use Try::Tiny; try { $session -> some_method_which_may_die; } catch { process_error($_); # Because $_ holds the error message. }; =head2 Trouble with Exiting If the session object's clean-up code is called, in DESTROY(), the session data is automatically flushed to storage (except when it's been deleted, or has not been modified). However, as explained below, there can be problems with your code (i.e. not with L) such that this clean-up code is not called, or, if called, it cannot perform as expected. The general guideline, then, is that you should explicitly call C on the session object before your program exits. Common traps for beginners: =over 4 =item o Creating 2 CGI-like objects If your code creates an object of type L or similar, but you don't pass that object into L via the 'query' parameter to new(), this module will create one for you, which can be very confusing. The solution is to always create such a object yourself, and to always pass that into L. In the case that the user of a CGI script runs your code for the first time, there will be no session id, either from a cookie or from a form field. In such a case, L will do what you expect, which is to generate a session id. =item o Letting your database handle go out of scope too early When your script is exiting, and you're trying to save session data to storage via a database handle, the save will fail if the handle goes out of scope before the session data is flushed to storage. So, don't do that. =item o Assuming your session object goes out of scope when it doesn't In persistent environments such as L, FastCGI and mod_perl, your code exits as expected, but the session object does not go out of scope in the normal way. In cases like this, it is mandatory for you to call flush() on the session object before your code exits, since persistent environments operate in such a way that the session object's clean-up code does not get called. This means that flush() is not called automatically by DESTROY() as you would expect, because DESTROY() is not being called. =item o Creating circular references anywhere in your code In these cases, Perl's clean-up code may not run to completion, which means the session object may not have its clean-up code called at all. As above, flush() may not get called. If you must create circular references, it's vital you debug the exit logic using a module such as L before assuming the fault is with L. =item o Using signal handlers Write your code defensively, if you wish to call the session object's flush() method when a signal might affect program exit logic. =back =head2 Trouble with IDs The module uses code like if (! $self -> id), which means ids must be (Perl) true values, so undef, 0 and '' will not work. =head2 Trouble with UUID16 While testing with UUID16 as the id generator, I got this message: ... invalid byte sequence for encoding "UTF8" ... That's because when I create a database (in Postgres) I use "create database d_name owner d_owner encoding 'UTF8';" and UUID16 simply produces a 16 byte binary value, which is not guaranteed to be or contain a valid UTF8 character. This also means you should never try to use 'driver:File;id:UUID16 ...', since the ids generated by this module would rarely if ever be valid as a part of a file name. =head2 Trouble with UUID64 While testing with UUID64 as the id generator, I got this message: ... Session ids cannot contain \ or / ... That's because I was using a File driver, and UUID's encoded in base 64 can contain /. So, don't do that. =head1 Version Numbers Version numbers < 1.00 represent development versions. From 1.00 up, they are production versions. =head1 Repository L =head1 Support LBugs should be reported via the CPAN bug tracker at L =head1 Thanks Many thanks are due to all the people who contributed to both L and L. Likewise, many thanks to the implementors of nesting testing. See L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/0000755000175000017500000000000014012132256015151 5ustar ronronData-Session-1.18/lib/Data/Session/ID.pm0000644000175000017500000000313314012132246016002 0ustar ronronpackage Data::Session::ID; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use File::Spec; use Hash::FieldHash ':all'; fieldhash my %id_length => 'id_length'; our $errstr = ''; our $VERSION = '1.18'; # ----------------------------------------------- sub init { my($class, $arg) = @_; $$arg{debug} ||= 0; $$arg{id} ||= 0; $$arg{id_base} ||= 0; # For AutoIncrement (AI). $$arg{id_file} ||= File::Spec -> catdir(File::Spec -> tmpdir, 'data.session.id'); # For AI. $$arg{id_length} = 0; # For UUID. $$arg{id_step} ||= 1; # For AI. $$arg{no_flock} ||= 0; $$arg{umask} ||= 0660; $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L is the parent of all L modules. =head1 Case-sensitive Options See L for important information. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Serialize/0000755000175000017500000000000014012132256017100 5ustar ronronData-Session-1.18/lib/Data/Session/Serialize/Storable.pm0000644000175000017500000000476414012132246021223 0ustar ronronpackage Data::Session::Serialize::Storable; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use Storable; our $VERSION = '1.18'; # ----------------------------------------------- sub freeze { my($self, $data) = @_; return Storable::freeze($data); } # End of freeze. # ----------------------------------------------- sub new { my($class) = @_; return bless({}, $class); } # End of new. # ----------------------------------------------- sub thaw { my($self, $data) = @_; return Storable::thaw($data); } # End of thaw. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. Warning: Storable should be avoided until this problem is fixed: L =head1 Description L allows L to manipulate sessions with L. To use this module do this: =over 4 =item o Specify a driver of type Storable as Data::Session -> new(type => '... serialize:Storable') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: freeze($data) Returns $data frozen by L. =head1 Method: thaw($data) Returns $data thawed by L. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Serialize/FreezeThaw.pm0000644000175000017500000000463114012132246021505 0ustar ronronpackage Data::Session::Serialize::FreezeThaw; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use FreezeThaw; our $VERSION = '1.18'; # ----------------------------------------------- sub freeze { my($self, $data) = @_; return FreezeThaw::freeze($data); } # End of freeze. # ----------------------------------------------- sub new { my($class) = @_; return bless({}, $class); } # End of new. # ----------------------------------------------- sub thaw { my($self, $data) = @_; return (FreezeThaw::thaw($data) )[0]; } # End of thaw. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions with L. To use this module do this: =over 4 =item o Specify a driver of type FreezeThaw as Data::Session -> new(type => '... serialize:FreezeThaw') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: freeze($data) Returns $data frozen by L. =head1 Method: thaw($data) Returns $data thawed by L. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Serialize/YAML.pm0000644000175000017500000000456214012132246020206 0ustar ronronpackage Data::Session::Serialize::YAML; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use YAML::Tiny (); our $VERSION = '1.18'; # ----------------------------------------------- sub freeze { my($self, $data) = @_; return YAML::Tiny::freeze($data); } # End of freeze. # ----------------------------------------------- sub new { my($class) = @_; return bless({}, $class); } # End of new. # ----------------------------------------------- sub thaw { my($self, $data) = @_; return YAML::Tiny::thaw($data); } # End of thaw. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions with L. To use this module do this: =over 4 =item o Specify a driver of type YAML as Data::Session -> new(type => '... serialize:YAML') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: freeze($data) Returns $data frozen by L. =head1 Method: thaw($data) Returns $data thawed by L. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Serialize/JSON.pm0000644000175000017500000000453714012132246020217 0ustar ronronpackage Data::Session::Serialize::JSON; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use JSON; our $VERSION = '1.18'; # ----------------------------------------------- sub freeze { my($self, $data) = @_; return JSON -> new -> encode($data); } # End of freeze. # ----------------------------------------------- sub new { my($class) = @_; return bless({}, $class); } # End of new. # ----------------------------------------------- sub thaw { my($self, $data) = @_; return JSON -> new -> decode($data); } # End of thaw. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions with L. To use this module do this: =over 4 =item o Specify a driver of type JSON as Data::Session -> new(type => '... serialize:JSON') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: freeze($data) Returns $data frozen by L. =head1 Method: thaw($data) Returns $data thawed by L. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Serialize/DataDumper.pm0000644000175000017500000001176414012132246021474 0ustar ronronpackage Data::Session::Serialize::DataDumper; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use Data::Dumper; use Safe; use Scalar::Util qw(blessed reftype refaddr); use vars qw( %overloaded ); require overload; our $VERSION = '1.18'; # ----------------------------------------------- sub freeze { my($self, $data) = @_; my($d) = Data::Dumper -> new([$data], ["D"]); $d -> Deepcopy(0); $d -> Indent(0); $d -> Purity(1); $d -> Quotekeys(1); $d -> Terse(0); $d -> Useqq(0); return $d ->Dump; } # End of freeze. # ----------------------------------------------- sub new { my($class) = @_; return bless({}, $class); } # End of new. # ----------------------------------------------- # We need to do this because the values we get back from the safe compartment # will have packages defined from the safe compartment's *main instead of # the one we use. sub _scan { # $_ gets aliased to each value from @_ which are aliases of the values in # the current data structure. for (@_) { if (blessed $_) { if (overload::Overloaded($_) ) { my($address) = refaddr $_; # If we already rebuilt and reblessed this item, use the cached # copy so our ds is consistent with the one we serialized. if (exists $overloaded{$address}) { $_ = $overloaded{$address}; } else { my($reftype) = reftype $_; if ($reftype eq "HASH") { $_ = $overloaded{$address} = bless { %$_ }, ref $_; } elsif ($reftype eq "ARRAY") { $_ = $overloaded{$address} = bless [ @$_ ], ref $_; } elsif ($reftype eq "SCALAR" || $reftype eq "REF") { $_ = $overloaded{$address} = bless \do{my $o = $$_}, ref $_; } else { die __PACKAGE__ . ". Do not know how to reconstitute blessed object of base type $reftype"; } } } else { bless $_, ref $_; } } } return @_; } # End of _scan. # ----------------------------------------------- sub thaw { my($self, $data) = @_; # To make -T happy. my($safe_string) = $data =~ m/^(.*)$/s; my($rv) = Safe -> new -> reval($safe_string); if ($@) { die __PACKAGE__ . ". Couldn't thaw. $@"; } _walk($rv); return $rv; } # End of thaw. # ----------------------------------------------- sub _walk { my(@filter) = _scan(shift); local %overloaded; my(%seen); # We allow the value assigned to a key to be undef. # Hence the defined() test is not in the while(). while (@filter) { defined(my $x = shift @filter) or next; $seen{refaddr $x || ''}++ and next; # The original syntax my($r) = reftype($x) or next led to if ($r...) # issuing an uninit warning when $r was undef. my($r) = reftype($x) || next; if ($r eq "HASH") { # We use this form to make certain we have aliases # to the values in %$x and not copies. push @filter, _scan(@{$x}{keys %$x}); } elsif ($r eq "ARRAY") { push @filter, _scan(@$x); } elsif ($r eq "SCALAR" || $r eq "REF") { push @filter, _scan($$x); } } } # End of _walk. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions with L. To use this module do this: =over 4 =item o Specify a driver of type DataDumper as Data::Session -> new(type=> '... serialize:DataDumper') =back The Data::Dumper options used are: $d -> Deepcopy(0); $d -> Indent(0); $d -> Purity(1); $d -> Quotekeys(1); $d -> Terse(0); $d -> Useqq(0); =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: freeze($data) Returns $data frozen by L. =head1 Method: thaw($data) Returns $data thawed by L. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver.pm0000644000175000017500000001224014012132246016740 0ustar ronronpackage Data::Session::Driver; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use DBI; use Hash::FieldHash ':all'; fieldhash my %created_dbh => 'created_dbh'; our $errstr = ''; our $VERSION = '1.18'; # ----------------------------------------------- sub DESTROY { my($self) = @_; (! $self -> dbh) && return; (! $self -> dbh -> ping) && die __PACKAGE__ . '. Database handle fails to ping'; (! ${$self -> dbh}{AutoCommit}) && $self -> dbh -> commit; if ($self -> created_dbh) { $self -> dbh -> disconnect; $self -> created_dbh(0); } $self -> dbh(''); } # End of DESTROY. # ----------------------------------------------- sub get_dbh { my($self, $arg) = @_; if ($self -> dbh) { (ref $self -> dbh eq 'CODE') && $self -> dbh($self -> dbh -> () ); } else { $self -> dbh ( DBI -> connect ( $self -> data_source, $self -> username, $self -> password, $self -> data_source_attr, ) || die __PACKAGE__ . ". Can't connect to database with dsn '" . $self -> data_source . "'" ); $self -> created_dbh(1); } } # End of get_dbh. # ----------------------------------------------- sub init { my($class, $arg) = @_; $$arg{created_dbh} = 0; $$arg{data_col_name} ||= 'a_session'; $$arg{data_source} ||= ''; $$arg{data_source_attr} ||= {AutoCommit => 1, PrintError => 0, RaiseError => 1}; $$arg{dbh} ||= ''; $$arg{host} ||= ''; $$arg{id} ||= 0; $$arg{id_col_name} ||= 'id'; $$arg{password} ||= ''; $$arg{port} ||= ''; $$arg{socket} ||= ''; $$arg{table_name} ||= 'sessions'; $$arg{username} ||= ''; $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- sub remove { my($self, $id) = @_; my($dbh) = $self -> dbh; local $$dbh{RaiseError} = 1; my($id_col_name) = $self -> id_col_name; my($table_name) = $self -> table_name; my($sql) = "delete from $table_name where $id_col_name = ?"; $dbh -> do($sql, {}, $id) || die __PACKAGE__ . ". Can't delete $id_col_name '$id' from table '$table_name'"; return 1; } # End of remove. # ----------------------------------------------- sub retrieve { my($self, $id) = @_; my($data_col_name) = $self -> data_col_name; my($dbh) = $self -> dbh; local $$dbh{RaiseError} = 1; my($id_col_name) = $self -> id_col_name; my($table_name) = $self -> table_name; my($sql) = "select $data_col_name from $table_name where $id_col_name = ?"; my($message) = __PACKAGE__ . "Can't %s in retrieve(). SQL: $sql"; my($sth) = $dbh -> prepare_cached($sql, {}, 3) || die sprintf($message, 'prepare_cached'); $sth -> execute($id) || die sprintf($message, 'execute'); my($row) = $sth -> fetch; $sth -> finish; # Return '' for failure. return $row ? $$row[0] : ''; } # End of retrieve. # ----------------------------------------------- sub traverse { my($self, $sub) = @_; if (! $sub || ref($sub) ne 'CODE') { die __PACKAGE__ . '. traverse() called without subref'; } my($dbh) = $self -> dbh; local $$dbh{RaiseError} = 1; my($id_col_name) = $self -> id_col_name; my($table_name) = $self -> table_name; my($sql) = "select $id_col_name from $table_name"; my($message) = __PACKAGE__ . "Can't %s in traverse(). SQL: $sql"; my($id) = $dbh -> selectall_arrayref($sql, {}) || die sprintf($message, 'selectall_arrayref'); for my $i (0 .. $#$id) { $sub -> ($$id[$i][0]); } return 1; } # End of traverse. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L is the parent of all L modules. =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. =head1 Method: remove($id) Deletes from storage the session identified by $id, or dies if it can't. Returns 1. =head1 Method: retrieve($id) Retrieve from storage the session identified by $id, or dies if it can't. Returns the session. This is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/0000755000175000017500000000000014012132256015445 5ustar ronronData-Session-1.18/lib/Data/Session/ID/SHA1.pm0000644000175000017500000000502614012132246016501 0ustar ronronpackage Data::Session::ID::SHA1; use parent 'Data::Session::SHA'; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; return $self -> SUPER::generate(1); } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 40; } # End of id_length. # ----------------------------------------------- sub new { my($class, %arg) = @_; $arg{verbose} ||= 0; return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate session ids using L. To use this module do this: =over 4 =item o Specify an id generator of type SHA1, as Data::Session -> new(type => '... id:SHA1 ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. The algorithm is Digest::SHA -> new(1) -> add($$, time, rand(time) ) -> hexdigest. Returns the new id. =head1 Method: id_length() Returns 40 because that's the number of hex digits in an SHA1 digest. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/UUID16.pm0000644000175000017500000000627714012132246016733 0ustar ronronpackage Data::Session::ID::UUID16; use parent 'Data::Session::ID'; no autovivification; use strict; use warnings; use Data::UUID; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; return Data::UUID -> new -> create_bin; } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 16; } # End of id_length. # ----------------------------------------------- sub init { my($self, $arg) = @_; $$arg{id_length} = 16; # Bytes. $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Case-sensitive Options See L for important information. To use this module do this: =over 4 =item o Specify an id generator of type UUID16, as Data::Session -> new(type => '... id:UUID16 ...') =back =head1 Description L allows L to generate session ids using L. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. The algorithm is Data::UUID -> new -> create_bin. Returns the new id. Note: A UUID16 hex string is not necessarily a valid UTF8 string, so you can't use UUID16 to generate ids which are to be stored in a Postgres table if the database was created like this (in psql): create database a_db owner an_owner encoding 'UTF8'; Warning: This also means you should never try to use 'driver:File;id:UUID16;...', since the ids generated by this module would rarely if ever be valid as a part of a file name. =head1 Method: id_length() Returns 16 because that's the number of bytes in a UUID16 digest. This can be used to generate the SQL to create the sessions table. See scripts/digest.pl. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/AutoIncrement.pm0000644000175000017500000001160014012132246020555 0ustar ronronpackage Data::Session::ID::AutoIncrement; use parent 'Data::Session::ID'; no autovivification; use strict; use warnings; use Fcntl qw/:DEFAULT :flock/; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; my($id_file) = $self -> id_file; (! $id_file) && die __PACKAGE__ . '. id_file not specifed in new(...)'; my($message) = __PACKAGE__ . ". Can't %s id_file '$id_file'. %s"; my($fh); sysopen($fh, $id_file, O_RDWR | O_CREAT, $self -> umask) || die sprintf($message, 'open', $self -> debug ? $! : ''); if (! $self -> no_flock) { flock($fh, LOCK_EX) || die sprintf($message, 'lock', $self -> debug ? $! : ''); } my($id) = <$fh>; if (! $id || ($id !~ /^\d+$/) ) { $id = $self -> id_base; } $id += $self -> id_step; seek($fh, 0, 0) || die sprintf($message, 'seek', $self -> debug ? $! : ''); truncate($fh, 0) || die sprintf($message, 'truncate', $self -> debug ? $! : ''); print $fh $id; close $fh || die sprintf($message, 'close', $self -> debug ? $! : ''); return $id; } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 32; } # End of id_length. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate session ids. To use this module do this: =over 4 =item o Specify an id generator of type AutoIncrement, as Data::Session -> new(type => '... id:AutoIncrement ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o id_base => $integer Specifies the base value for the auto-incrementing sessions ids. This key is normally passed in as Data::Session -> new(id_base => $integer). Note: The first id returned by generate() is id_base + id_step. Default: 0. This key is optional. =item o id_file => $file_name Specifies the file name in which to save the 'current' id. This key is normally passed in as Data::Session -> new(id_file => $file_name). Note: The next id returned by generate() is 'current' id + id_step. Default: File::Spec -> catdir(File::Spec -> tmpdir, 'data.session.id'). The reason Data::Session -> new(directory => ...) is not used as the default directory is because this latter option is for where the session files are stored if the driver is File and the id generator is not AutoIncrement. This key is optional. =item o id_step => $integer Specifies the amount to be added to the previous id to get the next id. This key is normally passed in as Data::Session -> new(id_step => $integer). Default: 1. This key is optional. =item o no_flock => $boolean Specifies (no_flock => 1) to not use flock() to obtain a lock on $file_name (which holds the 'current' id) before processing it, or (no_flock => 0) to use flock(). This key is normally passed in as Data::Session -> new(no_flock => $boolean). Default: 0. This key is optional. =item o umask => $octal_value Specifies the mode to use when calling sysopen() on $file_name. This key is normally passed in as Data::Session -> new(umask => $octal_value). Default: 0660. This key is optional. =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. Returns the new id. =head1 Method: id_length() Returns 32 because that's the classic value of the size of the id field in the sessions table. This can be used to generate the SQL to create the sessions table. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/SHA512.pm0000644000175000017500000000515614012132246016654 0ustar ronronpackage Data::Session::ID::SHA512; use parent 'Data::Session::SHA'; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; return $self -> SUPER::generate(512); } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 128; } # End of id_length. # ----------------------------------------------- sub new { my($class, %arg) = @_; $arg{verbose} ||= 0; return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate session ids using L. To use this module do this: =over 4 =item o Specify an id generator of type SHA512, as Data::Session -> new(type => '... id:SHA512 ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. The algorithm is Digest::SHA -> new(512) -> add($$, time, rand(time) ) -> hexdigest. Returns the new id. =head1 Method: id_length() Returns 128 because that's the number of hex digits in an SHA512 digest. This can be used to generate the SQL to create the sessions table. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/UUID34.pm0000644000175000017500000000556014012132246016725 0ustar ronronpackage Data::Session::ID::UUID34; use parent 'Data::Session::ID'; no autovivification; use strict; use warnings; use Data::UUID; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; return Data::UUID -> new -> create_hex; } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 34; } # End of id_length. # ----------------------------------------------- sub init { my($self, $arg) = @_; $$arg{id_length} = 34; # Bytes. $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate session ids using L. To use this module do this: =over 4 =item o Specify an id generator of type UUID34, as Data::Session -> new(type => '... id:UUID34 ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. The algorithm is Data::UUID -> new -> create_hex. Returns the new id. Note: L returns '0x' as the prefix of the 34-byte hex digest. You have been warned. =head1 Method: id_length() Returns 34 because that's the number of bytes in a UUID34 digest. This can be used to generate the SQL to create the sessions table. See scripts/digest.pl. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/SHA256.pm0000644000175000017500000000515414012132246016657 0ustar ronronpackage Data::Session::ID::SHA256; use parent 'Data::Session::SHA'; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; return $self -> SUPER::generate(256); } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 64; } # End of id_length. # ----------------------------------------------- sub new { my($class, %arg) = @_; $arg{verbose} ||= 0; return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate session ids using L. To use this module do this: =over 4 =item o Specify an id generator of type SHA256, as Data::Session -> new(type => '... id:SHA256 ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. The algorithm is Digest::SHA -> new(256) -> add($$, time, rand(time) ) -> hexdigest. Returns the new id. =head1 Method: id_length() Returns 64 because that's the number of hex digits in an SHA256 digest. This can be used to generate the SQL to create the sessions table. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/Static.pm0000644000175000017500000000557514012132246017245 0ustar ronronpackage Data::Session::ID::Static; use parent 'Data::Session::ID'; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; my($id) = $self -> id; (! $id) && die __PACKAGE__ . '. Static id (supplied to new) is not a true value'; return $id; } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 32; } # End of id_length. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate a static (constant) session id. To use this module do this: =over 4 =item o Specify an id generator of type Static, as Data::Session -> new(type => '... id:Static ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o id => $string Specifies the static (constant) id to 'generate'. This key is normally passed in as Data::Session -> new(id => $string). Default: 0. This key is mandatory, and can't be 0. =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id (which is always what was passed in to new(id => ...) ), or dies if it can't. Returns the new id. =head1 Method: id_length() Returns 32 because that's the classic value of the size of the id field in the sessions table. This can be used to generate the SQL to create the sessions table. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/UUID64.pm0000644000175000017500000000610514012132246016724 0ustar ronronpackage Data::Session::ID::UUID64; use parent 'Data::Session::ID'; no autovivification; use strict; use warnings; use Data::UUID; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; return Data::UUID -> new -> create_b64; } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 24; # sic. } # End of id_length. # ----------------------------------------------- sub init { my($self, $arg) = @_; $$arg{id_length} = 24; # Bytes. $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate session ids using L. To use this module do this: =over 4 =item o Specify an id generator of type UUID64, as Data::Session -> new(type => '... id:UUID64 ...') =back Note: The uuid will be 24 (sic) bytes because that's the number of bytes in a UUID64 digest. See scripts/digest.pl. =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. The algorithm is Data::UUID -> new -> create_b64. Returns the new id. Warning: You should never try to use 'driver:File;id:UUID64;...', since the ids generated by this module sometimes contain '/', which the code forbids to be part of a file name. =head1 Method: id_length() Returns 24 (sic) because that's the number of bytes in a UUID64 digest. This can be used to generate the SQL to create the sessions table. See scripts/digest.pl. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/UUID36.pm0000644000175000017500000000541714012132246016730 0ustar ronronpackage Data::Session::ID::UUID36; use parent 'Data::Session::ID'; no autovivification; use strict; use warnings; use Data::UUID; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; return Data::UUID -> new -> create_str; } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 36; } # End of id_length. # ----------------------------------------------- sub init { my($self, $arg) = @_; $$arg{id_length} = 36; # Bytes. $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate session ids using L. To use this module do this: =over 4 =item o Specify an id generator of type UUID36, as Data::Session -> new(type => '... id:UUID36 ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. The algorithm is Data::UUID -> new -> create_str. Returns the new id. =head1 Method: id_length() Returns 36 because that's the number of bytes in a UUID36 digest. This can be used to generate the SQL to create the sessions table. See scripts/digest.pl. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/ID/MD5.pm0000644000175000017500000000525514012132246016376 0ustar ronronpackage Data::Session::ID::MD5; use parent 'Data::Session::ID'; no autovivification; use strict; use warnings; use Digest::MD5; use Hash::FieldHash ':all'; our $errstr = ''; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self) = @_; return Digest::MD5 -> new -> add($$, time, rand(time) ) -> hexdigest; } # End of generate. # ----------------------------------------------- sub id_length { my($self) = @_; return 32; } # End of id_length. # ----------------------------------------------- sub new { my($class, %arg) = @_; $arg{verbose} ||= 0; return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to generate session ids using L. To use this module do this: =over 4 =item o Specify an id generator of type MD5, as Data::Session -> new(type => '... id:MD5 ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: generate() Generates the next session id, or dies if it can't. The algorithm is Digest::MD5 -> new -> add($$, time, rand(time) ) -> hexdigest. Returns the new id. =head1 Method: id_length() Returns 32 because that's the number of hex digits in a MD5 digest. This can be used to generate the SQL to create the sessions table. See scripts/digest.pl. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Base.pm0000644000175000017500000000634514012132246016370 0ustar ronronpackage Data::Session::Base; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; fieldhash my %cache => 'cache'; fieldhash my %data_col_name => 'data_col_name'; fieldhash my %data_source => 'data_source'; fieldhash my %data_source_attr => 'data_source_attr'; fieldhash my %dbh => 'dbh'; fieldhash my %debug => 'debug'; fieldhash my %deleted => 'deleted'; fieldhash my %directory => 'directory'; fieldhash my %driver_cless => 'driver_class'; fieldhash my %driver_option => 'driver_option'; fieldhash my %expired => 'expired'; fieldhash my %file_name => 'file_name'; fieldhash my %host => 'host'; fieldhash my %id => 'id'; fieldhash my %id_base => 'id_base'; fieldhash my %id_col_name => 'id_col_name'; fieldhash my %id_file => 'id_file'; fieldhash my %id_class => 'id_class'; fieldhash my %id_option => 'id_option'; fieldhash my %id_step => 'id_step'; fieldhash my %is_new => 'is_new'; fieldhash my %modified => 'modified'; fieldhash my %name => 'name'; fieldhash my %no_flock => 'no_flock'; fieldhash my %no_follow => 'no_follow'; fieldhash my %password => 'password'; fieldhash my %pg_bytea => 'pg_bytea'; fieldhash my %pg_text => 'pg_text'; fieldhash my %port => 'port'; fieldhash my %query => 'query'; fieldhash my %query_class => 'query_class'; fieldhash my %serializer_class => 'serializer_class'; fieldhash my %serializer_option => 'serializer_option'; fieldhash my %session => 'session'; fieldhash my %socket => 'socket'; fieldhash my %table_name => 'table_name'; fieldhash my %type => 'type'; fieldhash my %umask => 'umask'; fieldhash my %username => 'username'; fieldhash my %verbose => 'verbose'; our $errstr = ''; our $VERSION = '1.18'; # ----------------------------------------------- sub log { my($self, $s) = @_; $s ||= ''; print STDERR "# $s\n"; } # End of log. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description Provide a set of methods for all derived classes, including log(). =head1 Method: new() This class is never used on its own. =head1 Method: log($s) Print the string to STDERR. If $s is empty, use '' (the empty string), to avoid a warning message. Lastly, the string is output preceeded by a '#', so it does not interfere with test output. That is, log($s) emulates diag $s. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/CGISession.pm0000644000175000017500000002737214012132246017467 0ustar ronronpackage Data::Session::CGISession; our $VERSION = '1.18'; # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 The Design of Data::Session, contrasted with CGI::Session For background, read the docs (including the Changes files) and bug reports for both L and L. The interface to L is not quite compatible with that of L, hence the new namespace. The purpose of L is to be a brand-new alternative to both L and L. =head1 Aliases for Method Names Aliases for method names are not supported. In L, methods etime() and expires() were aliased to expire(). This is not supported in L. L does have an etime() method, L, which is different. In L, method header() was aliased to http_header(). Only the latter method is supported in L. See L and L. In L, id generators had a method generate_id() aliased to generate(). This is not supported in L. In L, method param_dataref() was aliased to dataref(). Neither of these methods is supported in L. If you want to access the session data, use my($hashref) = $session -> session. =head1 Backwards-compatibility This topic is sometimes used as a form of coercion, which is unacceptable, and sometimes leads to a crippled design. So, by design, L is not I backwards-compatible with L, but does retain it's major features: =over 4 =item o Specify the basic operating parameters with new(type => $string) This determines the type of session object you wish to create. Default: 'driver:File;id:MD5;serialize:DataDumper'. And specifically, the format of that case-sensitive string is as expected. See L for details. =item o Retrieve the session id with the id() method =item o Set and get parameters with the param() method =item o Ensure session data is saved to disk with the flush() method Call this just before your program exits. In particular, as with L, persistent environments stop your program exiting in the way you are used to. This matter is discussed in L. =back =head1 CGI::Session::ExpireSessions is obsolete Instead, consider using scripts/expire.pl, which ships with L. =head1 Code refs as database handles Being able to supply a code ref as the value of the 'dbh' parameter to new() is supported. This mechanism is used to delay creation of a database handle until it is actually needed, which means if it is not needed it is not created. =head1 Class 'v' Object Calling methods on the class is not supported. You must always create an object. The reason for this is to ensure every method call, without exception, has access to the per-object data supplied by you, or by default, in the call to new(). =head1 The type of the Data::Session object Controlling the capabilities of the L object is determined by the 'type' parameter passed in to new, as Data::Session -> new(type => $string). A sample string looks like 'driver:BerkeleyDB;id:SHA1;serialize:DataDumper'. Abbreviation of component key names ('driver', 'id', 'serialize') is not supported. Such abbreviations were previously handled by L. Now, these must be named in full. The decision to force corresponding class names to lower case is not supported. Nevertheless, lower-cased input will be accepted. Such input is converted to the case you expect. This affects the names of various sub-classes. See L, L and L. For example, driver:pg is now driver:Pg, which actually means L, based on the class name L. =head1 Exceptions Exceptions are caught with L. Errors cause L to die. The only exception to this is the call to new(), which can return undef. In that case, check $Data::Session::errstr. =head1 Global Variables Global variables are not supported. This includes: =over 4 =item o $CGI::Session::Driver::DBI::TABLE_NAME =item o $CGI::Session::Driver::DBI::*::TABLE_NAME =item o $CGI::Session::Driver::file::FileName =item o $CGI::Session::IP_MATCH =item o $CGI::Session::NAME =back =head1 ID Generators Id generator classes have been renamed: =over 4 =item o CGI::Session::ID::incr becomes L =item o CGI::Session::ID::md5 becomes L =item o CGI::Session::ID::sha becomes L =item o CGI::Session::ID::sha256 becomes L =item o CGI::Session::ID::sha512 becomes L =item o CGI::Session::ID::static becomes L =item o CGI::Session::ID::uuid becomes L or UUID34 or UUID36 or UUD64 =back =head1 JSON L uses L, not L. =head2 Managing Object Attributes The light-weight L is used to manage object attributes. So, neither L nor L, nor any other such class helper, is used. =head1 Method: cookie() Forcing the query object to have a cookie method is not supported. You may now use a query class which does not provide a cookie method. The logic of checking the cookie (if any) first (i.e. before checking for a form field of the same name) is supported. See L. =head1 Method: http_header([@arg]) The [] indicate an optional parameter. Returns a HTTP header. This means it does not print the header. You have to do that, when appropriate. Forcing the document type to be 'text/html' when calling http_header() is not supported. You must pass in a document type to http_header(), as $session -> http_header('-type' => 'text/html'), or use the query object's default. Both L and L default to 'text/html'. L handles the case where the query object does not have a cookie() method. The @arg parameter, if any, is passed to the query object's header() method, after the cookie parameter, if any. =head1 Method: load() The new load() takes no parameters. =head1 Method: new() Excess versions of new() are not supported. The new new() takes a hash of parameters. This hash will include all options previously passed in in different parameters to new(), including $dsn, $query, $sid, \%dsn_args and \%session_params. =head1 Name Changes Class name changes are discussed in L, L and L. As discussed in L, these name changes are both the result of cleaning up all the options to new(), and because the option names are now also method names. =over 4 =item o DataColName becomes data_col_name This is used in the call to new(). =item o DataSource becomes data_source This is used in the call to new(). =item o generate_id becomes generate This is used in various id generator classes, some of which provided generate as an alias. =item o Handle becomes dbh This is used in the call to new(). =item o IdColName becomes id_col_name This is used in the call to new(). =item o IDFile becomes id_file This is used in the call to new(), and in the '... id:AutoIncrement ...' id generator. =item o IDIncr becomes id_step This is used in the call to new(), and in the '... id:AutoIncrement ...' id generator. =item o IDInit becomes id_base This is used in the call to new(), and in the '... id:AutoIncrement ...' id generator. =back =head1 param() Excess versions of param() will not be supported. Use param($key => $value) to set and param($key) to get. param() may be passed a hash, to set several key/value pairs in 1 call. =head1 POD All POD has been re-written. =head1 Race Conditions The race handling code in L has been incorporated into other L drivers. =head1 Serialization Drivers Serializing classes have been renamed: =over 4 =item o CGI::Session::Serialize::default becomes L =item o CGI::Session::Serialize::freezethaw becomes L =item o CGI::Session::Serialize::json becomes L The latter will use L. In the past L was used. =item o CGI::Session::Serialize::storable becomes L =item o CGI::Session::Serialize::yaml becomes L The latter uses L. In the past either L or L was used. =back =head1 Session ids will be mandatory The ability to create a Perl object without a session id is not supported. Every time a object of type L is created, it must have an id. This id is either supplied by the caller, taken from the query object, or one is generated. See L for details. =head1 Session modification L tracks calls to param() to set a flag if the object is modified, so as to avoid writing the session to disk if nothing has been modified. This includes checking if setting a param's value to the value it already has. The behaviour is supported. =head1 Session Parameters L had these internal object attributes (parameters) not available to the user: =over 4 =item o _DATA Hashref: Keys: _SESSION_ATIME, _SESSION_CTIME, _SESSION_ID and _SESSION_REMOTE_ADDR. =item o _DSN Hashref. =item o _OBJECTS Hashref. =item o _DRIVER_ARGS Hashref. =item o _CLAIMED_ID Scalar. =item o _STATUS Scalar (bitmap). =item o _QUERY Scalar. =back L has these internal object attributes (parameters): =over 4 =item o _SESSION_ATIME Scalar: Last access time. =item o _SESSION_CTIME Scalar: Creation time. =item o _SESSION_ETIME Scalar: Expiry time. =item o _SESSION_ID Scalar: The id. =item o _SESSION_PTIME Hashref: Expiry times of parameters. =back L stores user data internally in a hashref, and the module reserves keys starting with '_'. Of course, it has a whole set of methods to manage state. =head1 Session States L objects can be one of 6 states. Every attempt has been made to simplify this design. =head1 Storage Drivers Classes related to DBI/DBD will use DBD::* style names, to help beginners. Hence (with special cases): =over 4 =item o CGI::Session::Driver::db_file becomes L The latter no longer uses DB_File. =item o CGI::Session::Driver::file becomes L =item o CGI::Session::Driver::memcached becomes L =item o CGI::Session::Driver::mysql becomes L =item o CGI::Session::Driver::odbc becomes L =item o CGI::Session::Driver::oracle becomes L =item o CGI::Session::Driver::postgresql becomes L =item o CGI::Session::Driver::sqlite becomes L =back =head1 Tests All tests have been re-written. =head1 The Version of Perl Perl 5 code will be used. =head1 YAML L uses L, not L or L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/SHA.pm0000644000175000017500000000273014012132246016123 0ustar ronronpackage Data::Session::SHA; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use Digest::SHA; use Hash::FieldHash ':all'; our $errstr = ''; our $VERSION = '1.18'; # ----------------------------------------------- sub generate { my($self, $bits) = @_; return Digest::SHA -> new($bits) -> add($$, time, rand(time) ) -> hexdigest; } # End of generate. # ----------------------------------------------- sub new { my($class, %arg) = @_; $arg{verbose} ||= 0; return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L is the parent of all L modules. =head1 Case-sensitive Options See L for important information. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver/0000755000175000017500000000000014012132256016404 5ustar ronronData-Session-1.18/lib/Data/Session/Driver/ODBC.pm0000644000175000017500000001363114012132246017454 0ustar ronronpackage Data::Session::Driver::ODBC; use parent 'Data::Session::Driver'; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; use Try::Tiny; our $VERSION = '1.18'; # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); my($self) = from_hash(bless({}, $class), \%arg); $self -> get_dbh(\%arg); return $self; } # End of new. # ----------------------------------------------- sub store { my($self, $id, $data) = @_; my($data_col_name) = $self -> data_col_name; my($dbh) = $self -> dbh; local $$dbh{RaiseError} = 1; my($id_col_name) = $self -> id_col_name; my($table_name) = $self -> table_name; my($sql) = "insert into $table_name ($data_col_name, $id_col_name) select ?, ? " . "on duplicate key update $data_col_name = ?"; $dbh -> do($sql, {}, $data, $id, $data) || die __PACKAGE__ . ". $DBI::errstr"; return 1; } # End of store. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to store sessions via L. To use this module do both of these: =over 4 =item o Specify a driver of type ODBC, as Data::Session -> new(type => 'driver:ODBC ...') =item o Specify a database handle as Data::Session -> new(dbh => $dbh), or a data source as Data::Session -> new(data_source => $string) =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o data_col_name => $string Specifes the name of the column in the sessions table which holds the session data. This key is normally passed in as Data::Session -> new(data_col_name => $string). Default: 'a_session'. This key is optional. =item o data_source => $string Specifies the data source (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source => $string). Default: ''. This key is optional, as long as a value is supplied for 'dbh'. =item o data_source_attr => $string Specifies the attributes (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source_attr => $string). Default: {AutoCommit => 1, PrintError => 0, RaiseError => 1}. This key is optional. =item o dbh => $dbh Specifies the database handle to use to access the sessions table. This key is normally passed in as Data::Session -> new(dbh => $dbh). If not specified, this module will use the values of these keys to obtain a database handle: =over 4 =item o data_source =item o data_source_attr =item o username =item o password =back Default: ''. This key is optional. =item o host => $string Not used. =item o id_col_name => $string Specifes the name of the column in the sessions table which holds the session id. This key is normally passed in as Data::Session -> new(id_col_name => $string). Default: 'id'. This key is optional. =item o password => $string Specifies the password (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(password => $string). Default: ''. This key is optional. =item o port => $string Not used. =item o socket => $string Not used. =item o table_name => $string Specifes the name of the sessions table. This key is normally passed in as Data::Session -> new(table_name => $string). Default: 'sessions'. This key is optional. =item o username => $string Specifies the username (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(username => $string). Default: ''. This key is optional. =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: remove($id) Deletes from storage the session identified by $id, or dies if it can't. Returns 1. =head1 Method: retrieve($id) Retrieve from storage the session identified by $id, or dies if it can't. Returns the session. This is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Method: store($id => $data) Writes to storage the session identified by $id, together with its data $data, or dies if it can't. Returns 1. =head1 Method: traverse() Retrieves all ids from the sessions table, and for each id calls the supplied subroutine with the id as the only parameter. $dbh -> selectall_arrayref is used, and the table is not locked. Returns 1. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver/Memcached.pm0000644000175000017500000001200014012132246020600 0ustar ronronpackage Data::Session::Driver::Memcached; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; use Try::Tiny; our $VERSION = '1.18'; # ----------------------------------------------- sub init { my($self, $arg) = @_; $$arg{cache} ||= ''; $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); (! $arg{cache}) && die __PACKAGE__ . '. No cache supplied to new(...)'; return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- sub remove { my($self, $id) = @_; return $self -> cache -> delete($id); } # End of remove. # ----------------------------------------------- sub retrieve { my($self, $id) = @_; # Return undef for failure. return $self -> cache -> get($id); } # End of retrieve. # ----------------------------------------------- sub store { my($self, $id, $data, $time) = @_; return $self -> cache -> set($id, $data, $time); } # End of store. # ----------------------------------------------- sub traverse { my($self, $sub) = @_; return 1; } # End of traverse. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions L. To use this module do both of these: =over 4 =item o Specify a driver of type Memcached, as Data::Session -> new(type => 'driver:Memcached ...') =item o Specify a cache object of type L as Data::Session -> new(cache => $object) =back See scripts/memcached.pl. =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o cache => $object Specifies the object of type L to use for session storage. This key is normally passed in as Data::Session -> new(cache => $object). This key is mandatory. =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: remove($id) Deletes from storage the session identified by $id. Returns the result of calling the L method delete($id). This result is a Boolean value indicating 1 => success or 0 => failure. =head1 Method: retrieve($id) Retrieve from storage the session identified by $id. Returns the result of calling the L method get($id). This result is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Method: store($id, $data, $time) Writes to storage the session identified by $id, together with its data $data. The expiry time of the object is passed into the set() method of L, too. Returns the result of calling the L method set($id, $data, $time). This result is a Boolean value indicating 1 => success or 0 => failure. Note: $time is 0 for sessions which don't expire. If you wish to pass undef or 'never', as per the L documentation, you will have to subclass L and override the set() method to change 0 to 'never'. =head1 Method: traverse() There is no mechanism (apart from memcached's debug code) to get a list of all keys in a cache managed by memcached, so there is no way to traverse them via this module. Returns 1. =head1 Installing memcached Get libevent from http://www.monkey.org/~provos/libevent/ I used V 2.0.8-rc ./configure make && make verify sudo make install It installs into /usr/local/lib, so tell memcached where to look: LD_LIBRARY_PATH=/usr/local/lib export LD_LIBRARY_PATH Get memcached from http://memcached.org/ I used V 1.4.5 ./configure --with-libevent=/usr/local/lib make && make test sudo make install Running memcached: memcached -m 5 & =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver/mysql.pm0000644000175000017500000001564014012132246020114 0ustar ronronpackage Data::Session::Driver::mysql; use parent 'Data::Session::Driver'; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; our $VERSION = '1.18'; # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); my($self) = from_hash(bless({}, $class), \%arg); my($dsn) = $self -> data_source; my(%attr) = ( host => 'host', port => 'port', socket => 'mysql_socket', ); for my $key (sort keys %attr) { if ($arg{$key}) { $dsn .= ";$attr{$key}=$arg{$key}"; } } $self -> data_source($dsn); $self -> get_dbh(\%arg); return $self; } # End of new. # ----------------------------------------------- sub store { my($self, $id, $data) = @_; my($data_col_name) = $self -> data_col_name; my($dbh) = $self -> dbh; local $$dbh{RaiseError} = 1; my($id_col_name) = $self -> id_col_name; my($table_name) = $self -> table_name; my($sql) = "insert into $table_name ($data_col_name, $id_col_name) select ?, ? " . "on duplicate key update $data_col_name = ?"; $dbh -> do($sql, {}, $data, $id, $data) || die __PACKAGE__ . ". $DBI::errstr"; return 1; } # End of store. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions via L. To use this module do both of these : =over 4 =item o Specify a driver of type mysql, as Data::Session -> new(type => 'driver:mysql ...') =item o Specify a database handle as Data::Session -> new(dbh => $dbh), or a data source as Data::Session -> new(data_source => $string) =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o data_col_name => $string Specifes the name of the column in the sessions table which holds the session data. This key is normally passed in as Data::Session -> new(data_col_name => $string). Default: 'a_session'. This key is optional. =item o data_source => $string Specifies the data source (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source => $string). Default: ''. This key is optional, as long as a value is supplied for 'dbh'. =item o data_source_attr => $hashref Specifies the attributes (as used by DBI -> connect($data_source, $username, $password, $attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source_attr => $hashref). Default: {AutoCommit => 1, PrintError => 0, RaiseError => 1}. This key is optional. =item o dbh => $dbh Specifies the database handle to use to access the sessions table. This key is normally passed in as Data::Session -> new(dbh => $dbh). If not specified, this module will use the values of these keys to obtain a database handle: =over 4 =item o data_source =item o data_source_attr =item o username =item o password =back Default: ''. This key is optional. =item o host => $string Specifies the host name to attach to the data_source. So Data::Session -> new(data_source => 'dbi:mysql:database=test', host => '192.168.100.1') generates the call $dbh = DBI -> connect('dbi:mysql:database=test;host=192.168.100.1', ...). =item o id_col_name => $string Specifes the name of the column in the sessions table which holds the session id. This key is normally passed in as Data::Session -> new(id_col_name => $string). Default: 'id'. This key is optional. =item o password => $string Specifies the password (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(password => $string). Default: ''. This key is optional. =item o port => $string Specifies the port number to attach to the data_source. So Data::Session -> new(data_source => 'dbi:mysql:database=test', port => '5000') generates the call $dbh = DBI -> connect('dbi:mysql:database=test;port=5000', ...). =item o socket => $string Specifies the socket to attach to the data_source. So Data::Session -> new(data_source => 'dbi:mysql:database=test', socket => '/dev/mysql.sock') generates the call $dbh = DBI -> connect('dbi:mysql:database=test;mysql_socket=/dev/mysql.sock', ...). The reason this key is called socket and not mysql_socket is in case other drivers permit a socket option. =item o table_name => $string Specifes the name of the sessions table. This key is normally passed in as Data::Session -> new(table_name => $string). Default: 'sessions'. This key is optional. =item o username => $string Specifies the username (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(username => $string). Default: ''. This key is optional. =item o verbose => $integer Print to STDERR more or less information. This key is normally passed in as Data::Session -> new(verbose => $integer). Typical values are 0, 1 and 2. This key is optional. =back =head1 Method: remove($id) Deletes from storage the session identified by $id, or dies if it can't. Returns 1. =head1 Method: retrieve($id) Retrieve from storage the session identified by $id, or dies if it can't. Returns the session. This is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Method: store($id => $data) Writes to storage the session identified by $id, together with its data $data, or dies if it can't. Returns 1. =head1 Method: traverse() Retrieves all ids from the sessions table, and for each id calls the supplied subroutine with the id as the only parameter. $dbh -> selectall_arrayref is used, and the table is not locked. Returns 1. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver/File.pm0000644000175000017500000002127614012132246017630 0ustar ronronpackage Data::Session::Driver::File; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use Fcntl qw/:DEFAULT :flock :mode/; use File::Path; use File::Spec; use Hash::FieldHash ':all'; use Try::Tiny; our $VERSION = '1.18'; # ----------------------------------------------- sub get_file_path { my($self, $sid) = @_; (my $id = $sid) =~ s|\\|/|g; ($id =~ m|/|) && die __PACKAGE__ . ". Session ids cannot contain \\ or /: '$sid'"; return File::Spec -> catfile($self -> directory, sprintf($self -> file_name, $sid) ); } # End of get_file_path. # ----------------------------------------------- sub init { my($self, $arg) = @_; $$arg{debug} ||= 0; $$arg{directory} ||= File::Spec -> tmpdir; $$arg{file_name} ||= 'cgisess_%s'; $$arg{id} ||= 0; $$arg{no_flock} ||= 0; $$arg{no_follow} ||= eval { O_NOFOLLOW } || 0; $$arg{umask} ||= 0660; $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); my($self) = from_hash(bless({}, $class), \%arg); ($self -> file_name !~ /%s/) && die __PACKAGE__ . ". file_name must contain %s"; if (! -d $self -> directory) { if (! File::Path::mkpath($self -> directory) ) { die __PACKAGE__ . ". Can't create directory '" . $self -> directory . "'"; } } return $self; } # End of new. # ----------------------------------------------- sub remove { my($self, $id) = @_; my($file_path) = $self -> get_file_path($id); unlink $file_path || die __PACKAGE__ . ". Can't unlink file '$file_path'. " . ($self -> debug ? $! : ''); return 1; } # End of remove. # ----------------------------------------------- sub retrieve { my($self, $id) = @_; my($file_path) = $self -> get_file_path($id); my($message) = __PACKAGE__ . ". Can't %s file '$file_path'. %s"; (! -e $file_path) && return ''; # Remove symlinks if possible. if (-l $file_path) { unlink($file_path) || die sprintf($message, 'unlink', $self -> debug ? $! : ''); } my($mode) = (O_RDWR | $self -> no_follow); my($fh); sysopen($fh, $file_path, $mode, $self -> umask) || die sprintf($message, 'open', $self -> debug ? $! : ''); # Sanity check. (-l $file_path) && die sprintf($message, "open it. It's a link, not a", ''); if (! $self -> no_flock) { flock($fh, LOCK_EX) || die sprintf($message, 'lock', $self -> debug ? $! : ''); } my($data) = ''; while (<$fh>) { $data .= $_; } close($fh) || die sprintf($message, 'close', $self -> debug ? $! : ''); return $data; } # End of retrieve. # ----------------------------------------------- sub store { my($self, $id, $data) = @_; my($file_path) = $self -> get_file_path($id); my($message) = __PACKAGE__ . ". Can't %s file '$file_path'. %s"; # Remove symlinks if possible. if (-l $file_path) { unlink($file_path) || die sprintf($message, 'unlink', $self -> debug ? $! : ''); } my($mode) = -e $file_path ? (O_WRONLY | $self -> no_follow) : (O_RDWR | O_CREAT | O_EXCL); my($fh); sysopen($fh, $file_path, $mode, $self -> umask) || die sprintf($message, 'open', $self -> debug ? $! : ''); # Sanity check. (-l $file_path) && die sprintf($message, "create it. It's a link, not a", ''); if (! $self -> no_flock) { flock($fh, LOCK_EX) || die sprintf($message, 'lock', $self -> debug ? $! : ''); } seek($fh, 0, 0) || die sprintf($message, 'seek', $self -> debug ? $! : ''); truncate($fh, 0) || die sprintf($message, 'truncate', $self -> debug ? $! : ''); print $fh $data; close($fh) || die sprintf($message, 'close', $self -> debug ? $! : ''); return 1; } # End of store. # ----------------------------------------------- sub traverse { my($self, $sub) = @_; if (! $sub || ref($sub) ne 'CODE') { die __PACKAGE__ . '. traverse() called without subref'; } my($pattern) = $self -> file_name; $pattern =~ s/\./\\./g; # Or /\Q.../. $pattern =~ s/%s/(\.\+)/; my($message) = __PACKAGE__ . ". Can't %s dir '" . $self -> directory . "' in traverse. %s"; opendir(INX, $self -> directory) || die sprintf($message, 'open', $self -> debug ? $! : ''); my($entry); # I do not use readdir(INX) || die .. here because I could not get it to work, # even with: while ($entry = (readdir(INX) || die sprintf($message, 'read', $!) ) ). # Every attempt triggered the call to die. while ($entry = readdir(INX) ) { next if ($entry =~ /^\.\.?/ || -d $entry); ($entry =~ /$pattern/) && $sub -> ($1); } closedir(INX) || die sprintf($message, 'close', $self -> debug ? $! : ''); return 1; } # End of traverse. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions via files. To use this module do this: =over 4 =item o Specify a driver of type File, as Data::Session -> new(type => 'driver:File ...') =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o debug => $Boolean Specifies that debugging should be turned on (1) or off (0) in L and L. When debug is 1, $! is included in error messages, but because this reveals directory names, it is 0 by default. This key is optional. Default: 0. =item o directory => $string Specifies the path to the directory which will contain the session files. This key is normally passed in as Data::Session -> new(directory => $string). Default: File::Spec -> tmpdir. This key is optional. =item o file_name => $string_containing_%s Specifies the pattern to use for session file names. It must contain 1 '%s', which will be replaced by the session id before the pattern is used as a file name. This key is normally passed in as Data::Session -> new(file_name => $string_containing_%s). Default: 'cgisess_%s'. This key is optional. =item o no_flock => $boolean Specifies (no_flock => 1) to not use flock() to obtain a lock on a session file before processing it, or (no_flock => 0) to use flock(). This key is normally passed in as Data::Session -> new(no_flock => $boolean). Default: 0. This key is optional. =item o no_follow => $value Influences the mode to use when calling sysopen() on session files. 'Influences' means the value is bit-wise ored with O_RDWR for reading and with O_WRONLY for writing. This key is normally passed in as Data::Session -> new(no_follow => $boolean). Default: eval{O_NOFOLLOW} || 0. This key is optional. =item o umask => $octal_value Specifies the mode to use when calling sysopen() on session files. This key is normally passed in as Data::Session -> new(umask => $octal_value). Default: 0660. This key is optional. =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: remove($id) Deletes from storage the session identified by $id. Returns 1 if it succeeds, and dies if it can't. =head1 Method: retrieve($id) Retrieves from storage the session identified by $id, or dies if it can't. Returns the result of reading the session from the file identified by $id. This result is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Method: store($id => $data) Writes to storage the session identified by $id, together with its data $data. Storage is a file identified by $id. Returns 1 if it succeeds, and dies if it can't. =head1 Method: traverse($sub) Retrieves all ids via their file names, and for each id calls the supplied subroutine with the id as the only parameter. Returns 1. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver/Pg.pm0000644000175000017500000001764414012132246017323 0ustar ronronpackage Data::Session::Driver::Pg; use parent 'Data::Session::Driver'; no autovivification; use strict; use warnings; use DBD::Pg qw(PG_BYTEA PG_TEXT); use Hash::FieldHash ':all'; use Try::Tiny; our $VERSION = '1.18'; # ----------------------------------------------- sub init { my($self, $arg) = @_; $self -> SUPER::init($arg); $$arg{pg_bytea} ||= 0; $$arg{pg_text} ||= 0; if ($$arg{pg_bytea} == 0 && $$arg{pg_text} == 0) { $$arg{pg_bytea} = 1; } elsif ($$arg{pg_bytea} == 1 && $$arg{pg_text} == 1) { $$arg{pg_text} = 0; } } # End of init. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); my($self) = from_hash(bless({}, $class), \%arg); $self -> get_dbh(\%arg); return $self; } # End of new. # ----------------------------------------------- sub store { my($self, $id, $data) = @_; my($data_col_name) = $self -> data_col_name; my($dbh) = $self -> dbh; local $$dbh{RaiseError} = 1; my($id_col_name) = $self -> id_col_name; my($table_name) = $self -> table_name; # There is a race condition were two clients could run this code concurrently, # and both end up trying to insert. That's why we check for "duplicate" below try { my($sql) = "insert into $table_name ($data_col_name, $id_col_name) select ?, ? " . "where not exists (select 1 from $table_name where $id_col_name = ? limit 1)"; my($sth) = $dbh -> prepare($sql); $sth -> bind_param(1, $data, {pg_type => $self -> pg_bytea ? PG_BYTEA : PG_TEXT}); $sth -> bind_param(2, $id); $sth -> bind_param(3, $id); my($rv); try { $rv = $sth -> execute; ($rv eq '0E0') && $self -> update($dbh, $table_name, $id_col_name, $data_col_name, $id, $data); } catch { if ($_ =~ /duplicate/) { $self -> update($dbh, $table_name, $id_col_name, $data_col_name, $id, $data); } else { die __PACKAGE__ . ". $_"; } }; $sth -> finish; } catch { die __PACKAGE__ . ". $_"; }; return 1; } # End of store. # ----------------------------------------------- sub update { my($self, $dbh, $table_name, $id_col_name, $data_col_name, $id, $data) = @_; my($sql) = "update $table_name set $data_col_name = ? where $id_col_name = ?"; my($sth) = $dbh -> prepare($sql); $sth -> bind_param(1, $data, {pg_type => $self -> pg_bytea ? PG_BYTEA : PG_TEXT}); $sth -> bind_param(2, $id); $sth -> execute; $sth -> finish; return 1; } # End of update. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions via L. To use this module do both of these: =over 4 =item o Specify a driver of type Pg, as Data::Session -> new(type => 'driver:Pg ...') =item o Specify a database handle as Data::Session -> new(dbh => $dbh) or a data source as Data::Session -> new(data_source => $string) =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o data_col_name => $string Specifes the name of the column in the sessions table which holds the session data. This key is normally passed in as Data::Session -> new(data_col_name => $string). Default: 'a_session'. This key is optional. =item o data_source => $string Specifies the data source (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source => $string). Default: ''. This key is optional, as long as a value is supplied for 'dbh'. =item o data_source_attr => $hashref Specifies the attributes (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source_attr => $hashref). Default: {AutoCommit => 1, PrintError => 0, RaiseError => 1}. This key is optional. =item o dbh => $dbh Specifies the database handle to use to access the sessions table. This key is normally passed in as Data::Session -> new(dbh => $dbh). If not specified, this module will use the values of these keys to obtain a database handle: =over 4 =item o data_source =item o data_source_attr =item o username =item o password =back Default: ''. This key is optional. =item o host => $string Not used. =item o id_col_name => $string Specifes the name of the column in the sessions table which holds the session id. This key is normally passed in as Data::Session -> new(id_col_name => $string). Default: 'id'. This key is optional. =item o password => $string Specifies the password (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(password => $string). Default: ''. This key is optional. =item o pg_bytea => $boolean Specifies (if pg_bytea => 1) that the a_session column in the sessions table is of type bytea. This key is normally passed in as Data::Session -> new(pg_bytea => $boolean). If both 'pg_bytea' and 'pg_text' are set to 1, 'pg_text' is forced to be 0. If both 'pg_bytea' and 'pg_text' are set to 0, 'pg_bytea' is forced to be 1. =item o pg_text => $boolean Specifies (if pg_text => 1) that the a_session column in the sessions table is of type text. This key is normally passed in as Data::Session -> new(pg_text => $boolean). =item o port => $string Not used. =item o socket => $string Not used. =item o table_name => $string Specifes the name of the sessions table. This key is normally passed in as Data::Session -> new(table_name => $string). Default: 'sessions'. This key is optional. =item o username => $string Specifies the username (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(username => $string). Default: ''. This key is optional. =item o verbose => $integer Print to STDERR more or less information. This key is normally passed in as Data::Session -> new(verbose => $integer). Typical values are 0, 1 and 2. This key is optional. =back =head1 Method: remove($id) Deletes from storage the session identified by $id, or dies if it can't. Returns 1. =head1 Method: retrieve($id) Retrieve from storage the session identified by $id, or dies if it can't. Returns the session. This is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Method: store($id => $data) Writes to storage the session identified by $id, together with its data $data, or dies if it can't. $dbh -> selectall_arrayref is used, and the table is not locked. Returns 1. =head1 Method: traverse() Retrieves all ids from the sessions table, and for each id calls the supplied subroutine with the id as the only parameter. Returns 1. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver/SQLite.pm0000644000175000017500000001613714012132246020112 0ustar ronronpackage Data::Session::Driver::SQLite; use parent 'Data::Session::Driver'; no autovivification; use strict; use warnings; use DBI qw(SQL_BLOB); use Hash::FieldHash ':all'; use Try::Tiny; our $VERSION = '1.18'; # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); my($self) = from_hash(bless({}, $class), \%arg); $self -> get_dbh(\%arg); my($dbh) = $self -> dbh; $$dbh{sqlite_handle_binary_nulls} = 1; $self -> dbh($dbh); return $self; } # End of new. # ----------------------------------------------- sub store { my($self, $id, $data) = @_; my($data_col_name) = $self -> data_col_name; my($dbh) = $self -> dbh; local $$dbh{RaiseError} = 1; my($id_col_name) = $self -> id_col_name; my($table_name) = $self -> table_name; # There is a race condition were two clients could run this code concurrently, # and both end up trying to insert. That's why we check for "duplicate" below try { my($sql) = "insert into $table_name ($data_col_name, $id_col_name) select ?, ? " . "where not exists (select 1 from $table_name where $id_col_name = ? limit 1)"; my($sth) = $dbh -> prepare($sql); $sth -> bind_param(1, $data, SQL_BLOB); $sth -> bind_param(2, $id); $sth -> bind_param(3, $id); my($rv); try { $rv = $sth -> execute; ($rv eq '0E0') && $self -> update($dbh, $table_name, $id_col_name, $data_col_name, $id, $data); } catch { if ($_ =~ /Error: .+ is not unique/) { $self -> update($dbh, $table_name, $id_col_name, $data_col_name, $id, $data); } else { die __PACKAGE__ . ". $_"; } }; $sth -> finish; } catch { die __PACKAGE__ . ". $_"; }; return 1; } # End of store. # ----------------------------------------------- sub update { my($self, $dbh, $table_name, $id_col_name, $data_col_name, $id, $data) = @_; my($sql) = "update $table_name set $data_col_name = ? where $id_col_name = ?"; my($sth) = $dbh -> prepare($sql); $sth -> bind_param(1, $data, SQL_BLOB); $sth -> bind_param(2, $id); $sth -> execute; $sth -> finish; } # End of update. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions via L. To use this module do both of these: =over 4 =item o Specify a driver of type SQLite, as Data::Session -> new(type => 'driver:SQLite ...') =item o Specify a database handle as Data::Session -> new(dbh => $dbh) or a data source as Data::Session -> new(data_source => $string) =back See scripts/sqlite.pl. =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o data_col_name => $string Specifes the name of the column in the sessions table which holds the session data. This key is normally passed in as Data::Session -> new(data_col_name => $string). Default: 'a_session'. This key is optional. =item o data_source => $string Specifies the data source (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source => $string). Default: ''. This key is optional, as long as a value is supplied for 'dbh'. =item o data_source_attr => $string Specifies the attributes (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source_attr => $string). Default: {AutoCommit => 1, PrintError => 0, RaiseError => 1}. This key is optional. =item o dbh => $dbh Specifies the database handle to use to access the sessions table. This key is normally passed in as Data::Session -> new(dbh => $dbh). If not specified, this module will use the values of these keys to obtain a database handle: =over 4 =item o data_source =item o data_source_attr =item o username =item o password =back Default: ''. This key is optional. =item o host => $string Not used. =item o id_col_name => $string Specifes the name of the column in the sessions table which holds the session id. This key is normally passed in as Data::Session -> new(id_col_name => $string). Default: 'id'. This key is optional. =item o password => $string Specifies the password (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(password => $string). Default: ''. This key is optional. =item o port => $string Not used. =item o socket => $string Not used. =item o table_name => $string Specifes the name of the sessions table. This key is normally passed in as Data::Session -> new(table_name => $string). Default: 'sessions'. This key is optional. =item o username => $string Specifies the username (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(username => $string). Default: ''. This key is optional. =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: remove($id) Deletes from storage the session identified by $id, or dies if it can't. Returns 1. =head1 Method: retrieve($id) Retrieve from storage the session identified by $id, or dies if it can't. Returns the session. This is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Method: store($id => $data) Writes to storage the session identified by $id, together with its data $data, or dies if it can't. Returns 1. =head1 Method: traverse() Retrieves all ids from the sessions table, and for each id calls the supplied subroutine with the id as the only parameter. $dbh -> selectall_arrayref is used, and the table is not locked. Returns 1. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver/Oracle.pm0000644000175000017500000001363214012132246020153 0ustar ronronpackage Data::Session::Driver::Oracle; use parent 'Data::Session::Driver'; no autovivification; use strict; use warnings; use Hash::FieldHash ':all'; use Try::Tiny; our $VERSION = '1.18'; # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); my($self) = from_hash(bless({}, $class), \%arg); $self -> get_dbh(\%arg); return $self; } # End of new. # ----------------------------------------------- sub store { my($self, $id, $data) = @_; my($data_col_name) = $self -> data_col_name; my($dbh) = $self -> dbh; local $$dbh{RaiseError} = 1; my($id_col_name) = $self -> id_col_name; my($table_name) = $self -> table_name; my($sql) = "insert into $table_name ($data_col_name, $id_col_name) select ?, ? " . "on duplicate key update $data_col_name = ?"; $dbh -> do($sql, {}, $data, $id, $data) || die __PACKAGE__ . ". $DBI::errstr"; return 1; } # End of store. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to store sessions via L. To use this module do both of these: =over 4 =item o Specify a driver of type Oracle, as Data::Session -> new(type => 'driver:Oracle ...') =item o Specify a database handle as Data::Session -> new(dbh => $dbh) or a data source as Data::Session -> new(data_source => $string) =back =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o data_col_name => $string Specifes the name of the column in the sessions table which holds the session data. This key is normally passed in as Data::Session -> new(data_col_name => $string). Default: 'a_session'. This key is optional. =item o data_source => $string Specifies the data source (as used by DBI -> connect($data_source, $username, $password, $attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source => $string). Default: ''. This key is optional, as long as a value is supplied for 'dbh'. =item o data_source_attr => $string Specifies the attributes (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(data_source_attr => $string). Default: {AutoCommit => 1, PrintError => 0, RaiseError => 1}. This key is optional. =item o dbh => $dbh Specifies the database handle to use to access the sessions table. This key is normally passed in as Data::Session -> new(dbh => $dbh). If not specified, this module will use the values of these keys to obtain a database handle: =over 4 =item o data_source =item o data_source_attr =item o username =item o password =back Default: ''. This key is optional. =item o host => $string Not used. =item o id_col_name => $string Specifes the name of the column in the sessions table which holds the session id. This key is normally passed in as Data::Session -> new(id_col_name => $string). Default: 'id'. This key is optional. =item o password => $string Specifies the password (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(password => $string). Default: ''. This key is optional. =item o port => $string Not used. =item o socket => $string Not used. =item o table_name => $string Specifes the name of the sessions table. This key is normally passed in as Data::Session -> new(table_name => $string). Default: 'sessions'. This key is optional. =item o username => $string Specifies the username (as used by DBI -> connect($data_source, $username, $password, $data_source_attr) ) to obtain a database handle. This key is normally passed in as Data::Session -> new(username => $string). Default: ''. This key is optional. =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: remove($id) Deletes from storage the session identified by $id, or dies if it can't. Returns 1. =head1 Method: retrieve($id) Retrieve from storage the session identified by $id, or dies if it can't. Returns the session. This is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Method: store($id => $data) Writes to storage the session identified by $id, together with its data $data, or dies if it can't. Returns 1. =head1 Method: traverse() Retrieves all ids from the sessions table, and for each id calls the supplied subroutine with the id as the only parameter. $dbh -> selectall_arrayref is used, and the table is not locked. Returns 1. =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/lib/Data/Session/Driver/BerkeleyDB.pm0000644000175000017500000001322614012132246020715 0ustar ronronpackage Data::Session::Driver::BerkeleyDB; use parent 'Data::Session::Base'; no autovivification; use strict; use warnings; use BerkeleyDB; use Hash::FieldHash ':all'; use Try::Tiny; our $VERSION = '1.18'; # ----------------------------------------------- sub init { my($self, $arg) = @_; $$arg{cache} ||= ''; $$arg{verbose} ||= 0; } # End of init. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); (! $arg{cache}) && die __PACKAGE__ . '. No cache supplied to new(...)'; return from_hash(bless({}, $class), \%arg); } # End of new. # ----------------------------------------------- sub remove { my($self, $id) = @_; my($lock) = $self -> cache -> cds_lock; my($status) = $self -> cache -> db_del($id); $lock -> cds_unlock; # Return '' for failure. return $status ? '' : 1; } # End of remove. # ----------------------------------------------- sub retrieve { my($self, $id) = @_; my($lock) = $self -> cache -> cds_lock; my($data) = ''; my($status) = $self -> cache -> db_get($id => $data); $lock -> cds_unlock; # Return '' for failure. return $status ? '' : $data; } # End of retrieve. # ----------------------------------------------- sub store { my($self, $id, $data) = @_; my($lock) = $self -> cache -> cds_lock; my($status) = $self -> cache -> db_put($id => $data); $lock -> cds_unlock; return $status ? '' : 1; } # End of store. # ----------------------------------------------- sub traverse { my($self, $sub) = @_; my($id, $data) = ('', ''); my($cursor) = $self -> cache -> db_cursor; while ($cursor -> c_get($id, $data, DB_NEXT) == 0) { $sub -> ($id); } undef $cursor; return 1; } # End of traverse. # ----------------------------------------------- 1; =pod =head1 NAME L - A persistent session manager =head1 Synopsis See L for details. =head1 Description L allows L to manipulate sessions via L. To use this module do both of these: =over 4 =item o Specify a driver of type BerkeleyDB, as Data::Session -> new(type => 'driver:BerkeleyDB ...') =item o Specify a cache object of type L as Data::Session -> new(cache => $object) Also, $object must have been created with a Env parameter of type L. See below. =back See scripts/berkeleydb.pl. =head1 Case-sensitive Options See L for important information. =head1 Method: new() Creates a new object of type L. C takes a hash of key/value pairs, some of which might mandatory. Further, some combinations might be mandatory. The keys are listed here in alphabetical order. They are lower-case because they are (also) method names, meaning they can be called to set or get the value at any time. =over 4 =item o cache => $object Specifies the object of type L to use for session storage. This key is normally passed in as Data::Session -> new(cache => $object). Warning: This cache object must have been set up both as an object of type L, and with that object having an Env parameter of type L, because this module - L - uses the L method cds_lock(). This key is mandatory. =item o verbose => $integer Print to STDERR more or less information. Typical values are 0, 1 and 2. This key is normally passed in as Data::Session -> new(verbose => $integer). This key is optional. =back =head1 Method: remove($id) Deletes from storage the session identified by $id. Returns the result of calling the L method delete($id). This result is a Boolean value indicating 1 => success or 0 => failure. =head1 Method: retrieve($id) Retrieve from storage the session identified by $id. Returns the result of calling the L method get($id). This result is a frozen session. This value must be thawed by calling the appropriate serialization driver's thaw() method. L calls the right thaw() automatically. =head1 Method: store($id => $data) Writes to storage the session identified by $id, together with its data $data. Returns the result of calling the L method set($id => $data). This result is a Boolean value indicating 1 => success or 0 => failure. =head1 Method: traverse() Retrieves all ids via a cursor, and for each id calls the supplied subroutine with the id as the only parameter. The database is not locked during this process. Returns 1. =head1 Installing BerkeleyDB Get Oracle's BerkeleyDB from http://www.oracle.com/technetwork/database/berkeleydb/overview/index.html I used V 5.1.19 tar xvzf db-5.1.19.tar.gz cd db-5.1.19/build_unix ../dist/configure make sudo make install It installs into /usr/local/BerkeleyDB.5.1 Get Perl's BerkeleyDB from http://search.cpan.org I used V 0.43 tar xvzf BerkeleyDB-0.43.tar.gz cd BerkeleyDB-0.43 Edit 2 lines in config.in: INCLUDE = /usr/local/BerkeleyDB.5.1/include LIB = /usr/local/BerkeleyDB.5.1/lib perl Makefile.PL make && make test sudo make install =head1 Support Log a bug on RT: L. =head1 Author L was written by Ron Savage Iron@savage.net.auE> in 2010. Home page: L. =head1 Copyright Australian copyright (c) 2010, Ron Savage. All Programs of mine are 'OSI Certified Open Source Software'; you can redistribute them and/or modify them under the terms of The Artistic License, a copy of which is available at: http://www.opensource.org/licenses/index.html =cut Data-Session-1.18/Makefile.PL0000644000175000017500000000413614012131152014057 0ustar ronronuse ExtUtils::MakeMaker; # ---------------- # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. my(%params) = ( ($] ge '5.005') ? ( AUTHOR => 'Ron Savage (ron@savage.net.au)', ABSTRACT => 'Persistent session data management', ) : (), clean => { FILES => 'blib/* Makefile MANIFEST Data-Session-*' }, dist => { COMPRESS => 'gzip', SUFFIX => 'gz' }, DISTNAME => 'Data-Session', LICENSE => 'perl', NAME => 'Data::Session', PL_FILES => {}, PREREQ_PM => { 'autovivification' => 0, 'CGI' => 3.63, 'Class::Load' => 0.19, 'Config::Tiny' => 2.14, 'Data::Dumper' => 2.145, 'Data::UUID' => 1.218, 'DBD::SQLite' => 1.39, 'DBI' => 1.627, 'DBIx::Admin::CreateTable' => 2.07, 'Digest::MD5' => 2.52, 'Digest::SHA' => 5.84, 'Fcntl' => 1.06, 'File::Basename' => 2.77, 'File::Path' => 2.07, 'File::Slurper' => 0.012, 'File::Spec' => 3.30, 'File::Temp' => 0.22, 'FreezeThaw' => 0.5001, 'Hash::FieldHash' => 0.14, 'JSON' => 2.59, 'overload' => 0, 'parent' => 0, 'Safe' => 2.35, 'Scalar::Util' => 1.27, 'Storable' => 2.39, 'strict' => 0, 'Try::Tiny' => 0.12, 'vars' => 0, 'warnings' => 0, 'YAML::Tiny' => 1.51, }, TEST_REQUIRES => { 'Test::More' => 1.001014, 'Test::Pod' => 1.48, }, VERSION_FROM => 'lib/Data/Session.pm', INSTALLDIRS => 'site', EXE_FILES => [], ); if ( ($ExtUtils::MakeMaker::VERSION =~ /^\d\.\d\d$/) && ($ExtUtils::MakeMaker::VERSION > 6.30) ) { $params{LICENSE} = 'artistic_2'; } if ($ExtUtils::MakeMaker::VERSION ge '6.46') { $params{META_MERGE} = { 'meta-spec' => { version => 2, }, resources => { bugtracker => { web => 'https://github.com/ronsavage/Data-Session/issues', }, license => 'http://opensource.org/licenses/Artistic-2.0', repository => { 'type' => 'git', 'url' => 'https://github.com/ronsavage/Data-Session.git', 'web' => 'https://github.com/ronsavage/Data-Session', }, }, }; } WriteMakefile(%params); Data-Session-1.18/META.yml0000644000175000017500000000255514012132256013367 0ustar ronron--- abstract: 'Persistent session data management' author: - 'Ron Savage (ron@savage.net.au)' build_requires: ExtUtils::MakeMaker: '0' Test::More: '1.001014' Test::Pod: '1.48' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.58, CPAN::Meta::Converter version 2.150010' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Data-Session no_index: directory: - t - inc requires: CGI: '3.63' Class::Load: '0.19' Config::Tiny: '2.14' DBD::SQLite: '1.39' DBI: '1.627' DBIx::Admin::CreateTable: '2.07' Data::Dumper: '2.145' Data::UUID: '1.218' Digest::MD5: '2.52' Digest::SHA: '5.84' Fcntl: '1.06' File::Basename: '2.77' File::Path: '2.07' File::Slurper: '0.012' File::Spec: '3.3' File::Temp: '0.22' FreezeThaw: '0.5001' Hash::FieldHash: '0.14' JSON: '2.59' Safe: '2.35' Scalar::Util: '1.27' Storable: '2.39' Try::Tiny: '0.12' YAML::Tiny: '1.51' autovivification: '0' overload: '0' parent: '0' strict: '0' vars: '0' warnings: '0' resources: bugtracker: https://github.com/ronsavage/Data-Session/issues license: http://opensource.org/licenses/Artistic-2.0 repository: https://github.com/ronsavage/Data-Session.git version: '1.18' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Data-Session-1.18/scripts/0000755000175000017500000000000014012132256013576 5ustar ronronData-Session-1.18/scripts/cgi.demo.cgi0000644000175000017500000000337712657730604015777 0ustar ronron#!/usr/bin/perl use CGI; use Data::Session; use File::Spec; # ---------------------------------------------- sub generate_html { my($name, $id, $count) = @_; $id ||= ''; my($title) = "CGI demo for Data::Session"; return < $title Number of times this script has been run: $count.
Current value of $name: $id.
EOS } # End of generate_html. # ---------------------------------------------- my($q) = CGI -> new; my($name) = 'sid'; # CGI form field name. my($sid) = $q -> param($name); my($dir_name) = '/tmp'; my($type) = 'driver:File;id:MD5;serialize:JSON'; my($session) = Data::Session -> new ( directory => $dir_name, name => $name, query => $q, type => $type, ); my($id) = $session -> id; # First entry ever? my($count); if ($sid) # Not $id, which always has a value... { # No. The CGI form field called sid has a (true) value. # So, this is the code for the second and subsequent entries. # Count the # of times this CGI script has been run. $count = $session -> param('count') + 1; } else { # Yes. There is no CGI form field called sid (with a true value). # So, this is the code for the first entry ever. # Count the # of times this CGI script has been run. $count = 0; } $session -> param(count => $count); print $q -> header, generate_html($name, $id, $count); # Calling flush() is good practice, rather than hoping 'things just work'. # In a persistent environment, this call is mandatory... # But you knew that, because you'd read the docs, right? $session -> flush; Data-Session-1.18/scripts/expire.pl0000644000175000017500000000231512657730604015446 0ustar ronron#!/usr/bin/env perl use lib 't'; use strict; use warnings; use Data::Session; use DBI; use File::Spec; use File::Temp; use Test; # ----------------------------------------------- # The EXLOCK is for BSD-based systems. my($directory) = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); my($data_source) = 'dbi:SQLite:dbname=' . File::Spec -> catdir($directory, 'sessions.sqlite'); my($type) = 'driver:SQLite;id:MD5;serialize:DataDumper'; my($tester) = Test -> new ( directory => $directory, dsn => $data_source, dsn_attr => {PrintError => 0}, # Stop msg when trying to delete non-existant table. password => '', type => $type, username => '', verbose => 1, ); $tester -> setup_table(128); my($session) = Data::Session -> new ( dbh => $tester -> dbh, type => $type, verbose => 0, # Affects parse_options(). ) || die $Data::Session::errstr; my($sub) = sub { my($id) = @_; my($s) = Data::Session -> new ( dbh => $tester -> dbh, id => $id, type => $type, verbose => 1, # Affects check_expiry() & parse_options(). ) || die $Data::Session::errstr; $s -> expire(-1); $s -> check_expiry; }; $session -> traverse($sub); Data-Session-1.18/scripts/file.sha1.pl0000644000175000017500000000163712657730604015732 0ustar ronron#!/usr/bin/env perl use strict; use warnings; use Data::Session; use File::Spec; use File::Temp; # ----------------------------------------------- # The EXLOCK is for BSD-based systems. my($directory) = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); my($file_name) = 'session.%s.dat'; my($type) = 'driver:File;id:SHA1;serialize:DataDumper'; # Case-sensitive. my($id); { my($session) = Data::Session -> new ( directory => $directory, file_name => $file_name, type => $type, ) || die $Data::Session::errstr; $id = $session -> id; $session -> param(a_key => 'a_value'); print "Id: $id. Save: a_key => a_value. \n"; } { my($session) = Data::Session -> new ( directory => $directory, file_name => $file_name, id => $id, type => $type, ) || die $Data::Session::errstr; print "Id: $id. Recover: a_key => ", $session -> param('a_key'), ". \n"; $session -> delete; } Data-Session-1.18/scripts/sqlite.pl0000644000175000017500000000235612657730604015460 0ustar ronron#!/usr/bin/env perl use lib 't'; use strict; use warnings; use Data::Session; use File::Spec; use File::Temp; use Test; # ----------------------------------------------- # The EXLOCK is for BSD-based systems. my($directory) = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); my($data_source) = 'dbi:SQLite:dbname=' . File::Spec -> catdir($directory, 'sessions.sqlite'); my($type) = 'driver:SQLite;id:SHA1;serialize:DataDumper'; # Case-sensitive. my($tester) = Test -> new ( directory => $directory, dsn => $data_source, dsn_attr => {PrintError => 0}, # Stop msg when trying to delete non-existant table. password => '', type => $type, username => '', verbose => 1, ); $tester -> setup_table(128); my($id); { my($session) = Data::Session -> new ( data_source => $data_source, type => $type, ) || die $Data::Session::errstr; $id = $session -> id; $session -> param(a_key => 'a_value'); print "Id: $id. Save a_key: a_value. \n"; } { my($session) = Data::Session -> new ( data_source => $data_source, id => $id, type => $type, ) || die $Data::Session::errstr; print "Id: $id. Recover a_key: ", $session -> param('a_key'), ". \n"; $session -> delete; } Data-Session-1.18/scripts/berkeleydb.pl0000644000175000017500000000214112657730604016257 0ustar ronron#!/usr/bin/env perl use strict; use warnings; use BerkeleyDB; use Data::Session; use File::Spec; use File::Temp; # ------------------- # The EXLOCK is for BSD-based systems. my($file_name) = File::Temp -> new(EXLOCK => 0, SUFFIX => '.bdb'); my($env) = BerkeleyDB::Env -> new ( Home => File::Spec -> tmpdir, Flags => DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL, ); if (! $env) { print "BerkeleyDB is not responding. \n"; exit; } my($bdb) = BerkeleyDB::Hash -> new(Env => $env, Filename => $file_name, Flags => DB_CREATE); if (! $bdb) { print "BerkeleyDB is not responding. \n"; exit; } my($type) = 'driver:BerkeleyDB;id:SHA1;serialize:DataDumper'; # Case-sensitive. my($id); { my($session) = Data::Session -> new ( cache => $bdb, type => $type, ) || die $Data::Session::errstr; $id = $session -> id; $session -> param(a_key => 'a_value'); print "Id: $id. Save a_key: a_value. \n"; } { my($session) = Data::Session -> new ( cache => $bdb, id => $id, type => $type, ) || die $Data::Session::errstr; print "Id: $id. Recover a_key: ", $session -> param('a_key'), ". \n"; $session -> delete; } Data-Session-1.18/scripts/cookie.pl0000644000175000017500000000153212657730604015423 0ustar ronron#!/usr/bin/env perl use strict; use warnings; use CGI; use Data::Session; use File::Spec; use File::Temp; # ------------------- # The EXLOCK is for BSD-based systems. my($directory) = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); my($data_source) = 'dbi:SQLite:dbname=' . File::Spec -> catdir($directory, 'sessions.sqlite'); my($session) = Data::Session -> new(data_source => $data_source) || die $Data::Session::errstr; $session -> expire(10); my($my_header) = $session -> http_header; print "<$my_header>\n"; my($q) = CGI -> new; my($cgi_cookie) = $q -> cookie(-name => 'CGISESSID', -value => $session -> id, -expires => '+10s'); my($cgi_header) = $q -> header(-cookie => $cgi_cookie, -type => 'text/html'); print "<$cgi_header>\n"; print $my_header eq $cgi_header ? 'Same' : 'Different'; print "\n"; Data-Session-1.18/scripts/cgi.sha1.pl0000644000175000017500000000173612657730604015555 0ustar ronron#!/usr/bin/env perl use strict; use warnings; use CGI; use Data::Session; use File::Spec; use File::Temp; # ----------------------------------------------- # The EXLOCK is for BSD-based systems. my($directory) = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); my($file_name) = 'session.%s.dat'; my($type) = 'driver:File;id:SHA1;serialize:DataDumper'; # Case-sensitive. my($id); { my($session) = Data::Session -> new ( directory => $directory, file_name => $file_name, type => $type, ) || die $Data::Session::errstr; $id = $session -> id; $session -> param(a_key => 'a_value'); print "Id: $id. Save: a_key => a_value. \n"; } { my($q) = CGI -> new; $q -> param(CGISESSID => $id); my($session) = Data::Session -> new ( directory => $directory, file_name => $file_name, query => $q, type => $type, ) || die $Data::Session::errstr; print "Id: $id. Recover: a_key => ", $session -> param('a_key'), ". \n"; $session -> delete; } Data-Session-1.18/scripts/memcached.pl0000644000175000017500000000157112657730604016063 0ustar ronron#!/usr/bin/env perl use strict; use warnings; use Cache::Memcached; use Data::Session; # ------------------- my($memd) = Cache::Memcached -> new({namespace => 'data.session.id', servers => ['127.0.0.1:11211']}); my($test) = $memd -> set(time => time); if (! $test || ($test != 1) ) { print "memcached is not responding. \n"; exit; } $memd -> delete('time'); my($type) = 'driver:Memcached;id:SHA1;serialize:DataDumper'; # Case-sensitive. my($id); { my($session) = Data::Session -> new ( cache => $memd, type => $type, ) || die $Data::Session::errstr; $id = $session -> id; $session -> param(a_key => 'a_value'); print "Id: $id. Save a_key: a_value. \n"; } { my($session) = Data::Session -> new ( cache => $memd, id => $id, type => $type, ) || die $Data::Session::errstr; print "Id: $id. Recover a_key: ", $session -> param('a_key'), ". \n"; $session -> delete; } Data-Session-1.18/scripts/digest.pl0000644000175000017500000000126112657730604015430 0ustar ronron#!/usr/bin/env perl use strict; use warnings; use Data::UUID; use Digest::SHA; use Digest::MD5; # ------------------- my($digest); for my $type (qw/create_bin create_hex create_str create_b64/) { $digest = Data::UUID -> new -> $type; print "Data::UUID -> new -> $type. length(digest): ", length($digest), ". \n"; } $digest = Digest::MD5 -> new -> add($$, time, rand(time) ) -> hexdigest; print "Digest::MD5 -> new -> add(...) -> hexdigest. length(digest): ", length($digest), ". \n"; for my $bits (1, 256, 512) { $digest = Digest::SHA -> new($bits) -> add($$, time, rand(time) ) -> hexdigest; print "Digest::SHA -> new($bits). length(digest): ", length($digest), ". \n"; } Data-Session-1.18/scripts/file.autoincrement.pl0000644000175000017500000000173212657730604017747 0ustar ronron#!/usr/bin/env perl use strict; use warnings; use Data::Session; use File::Spec; use File::Temp; # ----------------------------------------------- # The EXLOCK is for BSD-based systems. my($directory) = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); my($file_name) = 'autoinc.session.dat'; my($id_file) = File::Spec -> catfile($directory, $file_name); my($type) = 'driver:File;id:AutoIncrement;serialize:DataDumper'; # Case-sensitive. my($id); { my($session) = Data::Session -> new ( id_base => 99, id_file => $id_file, id_step => 2, type => $type, ) || die $Data::Session::errstr; $id = $session -> id; $session -> param(a_key => 'a_value'); print "Id: $id. Save: a_key => a_value. \n"; } { my($session) = Data::Session -> new ( id => $id, id_file => $id_file, type => $type, ) || die $Data::Session::errstr; print "Id: $id. Recover: a_key => ", $session -> param('a_key'), ". \n"; $session -> delete; } Data-Session-1.18/README0000644000175000017500000000250412657730604013006 0ustar ronronREADME file for Data::Session. See also: Changes.txt. Warning: WinZip 8.1 and 9.0 both contain an 'accidental' bug which stops them recognizing POSIX-style directory structures in valid tar files. You are better off using a reliable tool such as InfoZip: ftp://ftp.info-zip.org/pub/infozip/ 1 Installing from a Unix-like distro ------------------------------------ shell>gunzip Data-Session-0.01.tgz shell>tar mxvf Data-Session-0.01.tar On Unix-like systems, assuming you have installed Module::Build V 0.25+: shell>perl Build.PL shell>./Build shell>./Build test shell>./Build install On MS Windows-like systems, assuming you have installed Module::Build V 0.25+: shell>perl Build.PL shell>perl Build shell>perl Build test shell>perl Build install Alternately, without Module::Build, you do this: Note: 'make' on MS Windows-like systems may be called 'nmake' or 'dmake'. shell>perl Makefile.PL shell>make shell>make test shell>su (for Unix-like systems) shell>make install shell>exit (for Unix-like systems) On all systems: Run Session.pm through you favourite pod2html translator. 2 Installing from an ActiveState distro --------------------------------------- shell>unzip Data-Session-0.01.zip shell>ppm install --location=. Data-Session shell>del Data-Session-0.01.ppd shell>del PPM-Data-Session-0.01.tar.gz Data-Session-1.18/LICENSE0000644000175000017500000004740714011615554013136 0ustar ronronTerms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" ---------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS ---------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Data-Session-1.18/t/0000755000175000017500000000000014012132256012352 5ustar ronronData-Session-1.18/t/00.versions.tx0000644000175000017500000000077314011615554015032 0ustar ronron#/usr/bin/env perl use strict; use warnings; # I tried 'require'-ing modules but that did not work. use <: $module_name :>; # For the version #. use Test::More; <: $module_list_1 :> # ---------------------- pass('All external modules loaded'); my(@modules) = qw / <: $module_list_2 :> /; diag "Testing <: $module_name :> V $<: $module_name :>::VERSION"; for my $module (@modules) { no strict 'refs'; my($ver) = ${$module . '::VERSION'} || 'N/A'; diag "Using $module V $ver"; } done_testing; Data-Session-1.18/t/basic.t0000644000175000017500000001426612657730604013647 0ustar ronron#!/usr/bin/env perl no autovivification; use lib 't'; use strict; use warnings; use Class::Load ':all'; # For try_load_class() and is_class_loaded(). use Config::Tiny; use DBI; use File::Spec; use File::Temp; use Test; use Test::More; use Try::Tiny; # ----------------------------------------------- sub BEGIN { use_ok('Data::Session'); } # ----------------------------------------------- sub prepare_berkeleydb { my($self, $config) = @_; my($class) = 'BerkeleyDB'; my($cache); try { try_load_class($class); die "Unable to load class '$class'" if (! is_class_loaded($class) ); my($env) = BerkeleyDB::Env -> new ( Home => File::Spec -> tmpdir, Flags => BerkeleyDB::DB_CREATE() | BerkeleyDB::DB_INIT_CDB() | BerkeleyDB::DB_INIT_MPOOL(), ); if ($env) { $cache = BerkeleyDB::Hash -> new ( Env => $env, Filename => 'data.session.id.bdb', Flags => BerkeleyDB::DB_CREATE(), ); } if (! $cache) { # Avoid used-once warning. $BerkeleyDB::Error ||= $BerkeleyDB::Error; report("Skipping test. $class error: $BerkeleyDB::Error"); } } catch { report("Skipping test. Cannot load $class"); }; return $cache; } # End of prepare_berkeleydb. # ----------------------------------------------- sub prepare_memcached { my($self, $config) = @_; my($class) = 'Cache::Memcached'; my($cache); try { try_load_class($class); die "Unable to load class '$class'" if (! is_class_loaded($class) ); # Do a simple check to see if memcached is running. $cache = Cache::Memcached -> new({namespace => 'data.session.id', servers => ['127.0.0.1:11211']}); my($test) = $cache -> set(time => time); if ($test && ($test == 1) ) { # It's running, so clean up the test. $cache -> delete(time); } else { $cache = undef; report('Skipping test. memcached is not responding'); } } catch { report("Skipping test. Cannot load $class"); }; return $cache; } # End of prepare_memcached. # ----------------------------------------------- sub report { my($s) = @_; print STDERR "# $s\n"; } # End of report. # ----------------------------------------------- sub run { my($config, $id, $serializer, $test_count) = @_; my($cache); my(@dsn, $directory, $type); my($tester); try { # WTF: You cannot use DBI -> parse_dsn(...) || die $msg; # even though that's what the docs say to do. # BAIL_OUT reports (e.g.): ... Error in type: Unexpected component 'sha1' ... @dsn = DBI -> parse_dsn($$config{dsn}); if ($#dsn < 0) { die __PACKAGE__ . ". Can't parse dsn '$$config{dsn}'"; } if ($$config{dsn} =~ /dbi:BerkeleyDB/) { $cache = prepare_berkeleydb($config); if (! $cache) { return; } } elsif ($$config{dsn} =~ /dbi:Memcached/) { $cache = prepare_memcached($config); if (! $cache) { return; } } # The EXLOCK option is for BSD-based systems. $directory = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); $type = "driver:$dsn[1];id:$id;serialize:$serializer"; $tester = Test -> new ( cache => $cache, directory => $directory, dsn => $$config{dsn}, dsn_attr => $$config{attributes}, id => $id eq 'Static' ? 1234 : 0, id_base => 1000, # For id:AutoIncrement. id_step => 2, password => $$config{password}, type => $type, username => $$config{username}, verbose => 1, ); subtest $type => sub { $$test_count += $tester -> run; }; # At the end of run(), all sessions get deleted. # Hence we don't need to clean up the cache. #if ($$config{dsn} =~ /dbi:Memcached/) #{ # $cache -> flush_all; #} return $tester; } catch { # This extra call to done_testing just stops an extra error message. done_testing($$test_count); BAIL_OUT($_); }; } # End of run. # ----------------------------------------------- sub string2hashref { my($s) = @_; $s ||= ''; my($result) = {}; if ($s) { if ($s =~ m/^\{\s*([^}]*)\}$/) { my(@attr) = map{split(/\s*=>\s*/)} split(/\s*,\s*/, $1); if (@attr) { $result = {@attr}; } } else { die "Invalid syntax for hashref: $s"; } } return $result; } # End of string2hashref. # ----------------------------------------------- my($ini_file) = shift || 't/basic.ini'; my($dsn_config) = Config::Tiny -> read($ini_file); my($test_count) = 1; # The use_ok in BEGIN counts as the first test. my($config); my($temp, $tester); for my $dsn_name (sort keys %$dsn_config) { $config = $$dsn_config{$dsn_name}; $$config{attributes} = string2hashref($$config{attributes}); next if ( ($$config{active} == 0) || ($$config{use_for_testing} == 0) ); $temp = Test -> new(dsn => $$config{dsn}, type => 'Fake'); if ($temp -> check_sqlite_directory_exists == 0) { report("Skipping dsn '$$config{dsn}' because the SQLite directory does not exist"); next; } # We skip UUID16 since echoing such ids to the console can change the char set (under bash). for my $id (qw/AutoIncrement MD5 SHA1 SHA256 SHA512 Static UUID34 UUID36 UUID64/) { for my $serializer (qw/DataDumper FreezeThaw JSON Storable YAML/) { # Skip special cases (See FAQ): # o driver:File and ID::UUID64 (Invalid file name). # o driver:Pg and ID::UUID16 (Invalid UTF8). next if ( ($$config{dsn} =~ /dbi:File/) && ($id eq 'UUID64') ); next if ( ($$config{dsn} =~ /dbi:Pg/) && ($id eq 'UUID16') ); report("Test: $dsn_name. DSN: $$config{dsn}. ID generator: $id. Serializer: $serializer"); $tester = run($config, $id, $serializer, \$test_count); } } } # For these tests, we don't care which tester object we ended up with. # It's just we don't want to call these every time thru to loops above. # # Test generating a HTTP header with a cookie. $test_count += $tester -> test_cookie_and_http_header; # Test validation of time strings such as -10 +10d and 10M. $test_count += $tester -> test_validation_of_time_strings; # Test expiring a session and then reading it back in, to lose parameters. $test_count += $tester -> test_expire_the_session; # Test expiring a session parameter, and then reading it back in, to lose that parameter. $test_count += $tester -> test_expire_a_session_parameter; done_testing($test_count); Data-Session-1.18/t/Test.pm0000644000175000017500000004724214012132246013637 0ustar ronronpackage Test; no autovivification; use strict; use warnings; use CGI; #use Data::Session; # The caller did use_ok on Data::Session. use DBI; use DBIx::Admin::CreateTable; use File::Basename; use File::Spec; use Hash::FieldHash ':all'; use Test::More; fieldhash my %cache => 'cache'; fieldhash my %column_type => 'column_type'; fieldhash my %creator => 'creator'; fieldhash my %dbh => 'dbh'; fieldhash my %directory => 'directory'; fieldhash my %dsn => 'dsn'; fieldhash my %dsn_attr => 'dsn_attr'; fieldhash my %engine => 'engine'; fieldhash my %id => 'id'; fieldhash my %id_base => 'id_base'; fieldhash my %id_file => 'id_file'; fieldhash my %id_step => 'id_step'; fieldhash my %key => 'key'; fieldhash my %type => 'type'; fieldhash my %password => 'password'; fieldhash my %table_name => 'table_name'; fieldhash my %test_count => 'test_count'; fieldhash my %username => 'username'; fieldhash my %value => 'value'; fieldhash my %verbose => 'verbose'; our $errstr = ''; our $VERSION = '1.18'; # ----------------------------------------------- sub check_sqlite_directory_exists { my($self) = @_; my(@dsn) = DBI -> parse_dsn($self -> dsn); my($result) = 1; # Success. if ($dsn[4] && ($dsn[1] =~ /^SQLite/i) ) { my($file, $dir, $suffix) = fileparse($dsn[4]); $result = 0 if (! -e $dir); } return $result; } # End of check_sqlite_directory_exists. # ----------------------------------------------- sub create_session_from_id { my($self, $id) = @_; return Data::Session -> new ( cache => $self -> cache, data_source => $self -> dsn, data_source_attr => $self -> dsn_attr, directory => $self -> directory, id => $id, id_base => $self -> id_base, id_file => $self -> id_file, id_step => $self -> id_step, password => $self -> password, type => $self -> type, username => $self -> username, verbose => $self -> verbose, ) || die __PACKAGE__ . ". $Data::Session::errstr"; } # End of create_session_from_id. # ----------------------------------------------- sub create_session_from_q { my($self, $session1) = @_; my($q) = CGI -> new; $q -> param(sid => $session1 -> id); $q -> param($self -> key => $self -> value); return Data::Session -> new ( cache => $self -> cache, data_source => $self -> dsn, data_source_attr => $self -> dsn_attr, directory => $self -> directory, id => $session1 -> id, id_base => $self -> id_base, id_file => $self -> id_file, id_step => $self -> id_step, name => 'sid', password => $self -> password, query => $q, type => $self -> type, username => $self -> username, verbose => $self -> verbose, ) || die __PACKAGE__ . ". $Data::Session::errstr"; } # End of create_session_from_q. # ----------------------------------------------- sub create_session_from_scratch { my($self) = @_; return Data::Session -> new ( cache => $self -> cache, data_source => $self -> dsn, data_source_attr => $self -> dsn_attr, directory => $self -> directory, id => $self -> id, id_base => $self -> id_base, id_file => $self -> id_file, id_step => $self -> id_step, password => $self -> password, type => $self -> type, username => $self -> username, verbose => $self -> verbose, ) || die __PACKAGE__ . ". $Data::Session::errstr"; } # End of create_session_from_scratch. # ----------------------------------------------- sub create_table { my($self, $table_name, $id_length) = @_; my($engine) = $self -> engine; my($column_type) = $self -> column_type; my($result) = $self -> creator -> create_table(< 1}); create table $table_name ( id char($id_length) not null primary key, a_session $column_type not null ) $engine SQL } # End of create_table. # ----------------------------------------------- sub dump { my($self) = @_; $self -> log('cache: ' . $self -> cache); $self -> log('column_type: ' . $self -> column_type); $self -> log('creator: ' . $self -> creator); $self -> log('dbh: ' . $self -> dbh); $self -> log('directory: ' . $self -> directory); $self -> log('dsn: ' . $self -> dsn); $self -> log('dsn_attr: ' . $self -> hashref2string($self -> dsn_attr) ); $self -> log('engine: ' . $self -> engine); $self -> log('id: ' . $self -> id); $self -> log('id_base: ' . $self -> id_base); $self -> log('id_file: ' . $self -> id_file); $self -> log('id_step: ' . $self -> id_step); $self -> log('key: ' . $self -> key); $self -> log('password: ' . $self -> password); $self -> log('table_name: ' . $self -> table_name); $self -> log('test_count: ' . $self -> test_count); $self -> log('type: ' . $self -> type); $self -> log('username: ' . $self -> username); $self -> log('value: ' . $self -> value); $self -> log('verbose: ' . $self -> verbose); } # End of dump. # ----------------------------------------------- sub init { my($self, $arg) = @_; $$arg{cache} ||= ''; # new(cache => ...). $$arg{column_type} = ''; $$arg{creator} = ''; $$arg{dbh} = ''; $$arg{directory} ||= File::Spec -> tmpdir; # new(directory => ...). $$arg{dsn} ||= ''; # new(dsn => ...). $$arg{dsn_attr} ||= ''; # new(dsn_attr => ...). $$arg{engine} = ''; $$arg{id} ||= 0; # new(id => ...). $$arg{id_base} ||= 0; # new(id_base => ...). $$arg{id_file} ||= File::Spec -> catdir(File::Spec -> tmpdir, 'data.session.id'); # new(id_file => ...). $$arg{id_step} ||= 1; # new(id_step => ...). $$arg{key} = 'Perl'; $$arg{password} ||= ''; # new(password => ...). $$arg{table_name} = 'sessions'; $$arg{test_count} = 0; # The caller did use_ok on Data::Session. $$arg{type} ||= ''; # new(type => ...). $$arg{username} ||= ''; # new(username => ...). $$arg{value} = 'Language'; $$arg{verbose} ||= 0; # new(verbose => ...). } # End of init. # ----------------------------------------------- sub hashref2string { my($self, $h) = @_; $h ||= {}; return '{' . join(', ', map{"$_ => $$h{$_}"} sort keys %$h) . '}'; } # End of hashref2string. # ----------------------------------------------- sub log { my($self, $s) = @_; $s ||= ''; print STDERR "# $s\n"; } # End of log. # ----------------------------------------------- sub new { my($class, %arg) = @_; $class -> init(\%arg); # Expected format: new(type => 'driver:Pg;id:MD5;serialize:FreezeThaw'). if (! $arg{type}) { die __PACKAGE__ . '. No type specified in $obj -> new(...)'; } # Expected format: new(dsn => 'dbi:Pg:dbname=test'). if (! $arg{dsn}) { die __PACKAGE__ . '. No dsn specified in $obj -> new(...)'; } my($self) = from_hash(bless({}, $class), \%arg); return $self; } # End of new. # ----------------------------------------------- sub run { my($self) = @_; ($self -> verbose > 1) && $self -> dump; # Special code for SQLite. The table /must/ exist. # # However, for tests, we always re-create the table, although # users would not normally do this. The reason is that if a # test is for id:Static, serialize:DataDumper, and the next # test is for serialize::FreezeThaw, the static id means the # 2nd test uses the first id's data, which is in DataDumper format. # # For BerkeleyDB, Files and Memcached, skip, since we do not have database tables. if ($self -> type !~ /driver:(?:BerkeleyDB|File|Memcached)/) { # We rig it to use an id length of 128, since the table # is deleted and re-created below before being written to. $self -> setup_table(128); } my($session1) = $self -> create_session_from_scratch; isa_ok($session1, 'Data::Session', '1st session object'); $self -> test_count($self -> test_count + 1); $self -> log('id 1: ' . $session1 -> id); # For BerkeleyDB, Files and Memcached, skip, since we do not have database tables. if ($self -> type !~ /driver:(?:BerkeleyDB|File|Memcached)/) { # This time use the real length of the ID. $self -> setup_table($session1 -> id_class -> id_length); } # Set up some test data to play with. my($key) = $self -> key; my($value) = $self -> value; $session1 -> param($key => $value); $session1 -> param("$key$key" => "$value$value"); $session1 -> flush; # Create a session using the first session's id. my($session2) = $self -> test_session_from_id($session1); # Create a session using a query object based on the first session. my($session3) = $self -> test_session_from_q($session1); # Test save_param and load_param. my($session4) = $self -> test_save_load_param($session1); # Testing setting a parameter to undef. $self -> test_setting_getting_undef; # Clean up. All sessions must be deleted, otherwise they get flushed by Session::Data's DESTROY. $session1 -> delete; $session2 -> delete; $session3 -> delete; $session4 -> delete; done_testing($self -> test_count); # Return 1 to keep the outer done_testing happy. return 1; } # End of run. # ----------------------------------------------- sub setup_table { my($self, $id_length) = @_; $self -> dbh(DBI -> connect($self -> dsn, $self -> username, $self -> password, $self -> dsn_attr) || die __PACKAGE__ . ". Can't connect to " . $self -> dsn); $self -> creator(DBIx::Admin::CreateTable -> new(dbh => $self -> dbh, verbose => 0) ); my($vendor) = $self -> creator -> db_vendor; $self -> column_type($vendor eq 'ORACLE' ? 'long' : $vendor eq 'POSTGRESQL' ? 'bytea' : 'text'); $self -> engine($vendor =~ /(?:Mysql)/i ? 'engine=innodb' : ''); $self -> creator -> drop_table($self -> table_name); $self -> create_table($self -> table_name, $id_length); if ($self -> table_exists == 0) { die __PACKAGE__ . ". Can't create '" . $self -> table_name . "' table"; } } # End of setup_table. # ----------------------------------------------- sub table_exists { my($self) = @_; my($table_sth) = $self -> dbh -> table_info(undef, undef, '%', 'TABLE'); my($result) = 0; for my $table_data (@{$table_sth -> fetchall_arrayref({})}) { if ($$table_data{'TABLE_NAME'} eq $self -> table_name) { $result = 1; } } return $result; } # End of table_exists. # ----------------------------------------------- sub test_cookie_and_http_header { my($self) = @_; $self -> log; $self -> log("Testing HTTP header generation"); my($session) = $self -> create_session_from_scratch; $session -> expire(10); my($my_header) = $session -> http_header; my($q) = CGI -> new; my($cgi_cookie) = $q -> cookie(-name => 'CGISESSID', -value => $session -> id, -expires => '+10s'); my($cgi_header) = $q -> header(-cookie => $cgi_cookie, -type => 'text/html'); ok($my_header eq $cgi_header, 'HTTP header created via CGI directly matches one via http_header()'); # Return test count. return 1; } # End of test_cookie_and_http_header. # ----------------------------------------------- sub test_expire_a_session_parameter { my($self) = @_; my($count) = 0; my($delay) = 1; # Second. my(%data) = ( key_1 => { expire => 0, value => 'value_1', }, key_2 => { expire => $delay, value => 'value_2', }, ); my($id); # 1: Create a session, and when it goes out of scope, it's saved to storage. { my($session) = $self -> create_session_from_scratch; $id = $session -> id; for my $key (keys %data) { $session -> expire($key => $data{$key}{expire}); $session -> param($key => $data{$key}{value}); } } # 2: Sleep beyond the expiry time, and read the session back in. $self -> log; $self -> log("Testing expire a session parameter. Sleeping for $delay second ..."); $delay = 3 * $delay; sleep($delay); my($session) = $self -> create_session_from_id($id); my($ptime) = $session -> ptime; for my $key (sort keys %$ptime) { $self -> log("Recovered $key: $$ptime{$key}"); } # We should have lost key_2 by now. my($data); for my $key (keys %data) { $data = $session -> param($key); if ($key eq 'key_1') { ok(defined $data, "Data for key $key not expired, and hence retrieved from storage"); } else { ok(! defined $data, "Data for key $key expired, and hence not retrieved from storage"); } # This is not called, because we're running after the inner done_testing(). #$self -> test_count($self -> test_count + 1); $count++; } # Return test count. return $count; } # End of test_expire_a_session_parameter. # ----------------------------------------------- sub test_expire_the_session { my($self) = @_; my($key) = 'Perl'; my($value) = 'Language'; my($count) = 0; my($delay) = 1; # Second. my($id); # 1: Create a session, and when it goes out of scope, it's saved to storage. { my($session) = $self -> create_session_from_scratch; $id = $session -> id; $session -> expire($delay); $session -> param($key => $value); my($secs) = $session -> expire; ok($delay == $secs, 'Expiry time set and retrieved'); # This is not called, because we're running after the inner done_testing(). #$self -> test_count($self -> test_count + 1); $count++; } # 2: Sleep beyond the expiry time, and read the session back in. $self -> log; $self -> log("Testing expire the session. Sleeping for $delay second ..."); $delay = 3 * $delay; sleep($delay); my($session) = $self -> create_session_from_id($id); # We should have lost $key by now. my($data) = $session -> param($key); ok(! defined $data, 'Data expired, and hence not retrieved from storage'); # This is not called, because we're running after the inner done_testing(). #$self -> test_count($self -> test_count + 1); $count++; # Return test count. return $count; } # End of test_expire_the_session. # ----------------------------------------------- sub test_save_load_param { my($self, $session1) = @_; # 1: Stuff some data into a query object. my($q1) = CGI -> new; my(%data) = ( key_1 => 'value_1', key_2 => 'value_2', ); my($key); for $key (keys %data) { $q1 -> param($key => $data{$key}); } # 2: Test save param, copying data from a query object to a session. my($session4) = $self -> create_session_from_scratch; $session4 -> save_param($q1, [keys %data]); my($total1) = ''; my($total2) = ''; for $key (keys %data) { $total1 .= $data{$key}; $total2 .= $session4 -> param($key); } ok($total1 eq $total2, 'Data recovered from save_param() matches'); $self -> test_count($self -> test_count + 1); # 3: Test load param, copying data from a session to a query object. my($q2) = $session4 -> load_param(undef, [keys %data]); $total1 = ''; $total2 = ''; for $key (keys %data) { $total1 .= $data{$key}; $total2 .= $q2 -> param($key); } ok($total1 eq $total2, 'Data recovered from load_param() matches'); $self -> test_count($self -> test_count + 1); return $session4; } # End of test_save_load_param. # ----------------------------------------------- sub test_session_from_id { my($self, $session1) = @_; my($session2) = $self -> create_session_from_id($session1 -> id); isa_ok($session2, 'Data::Session', '2nd session object'); $self -> test_count($self -> test_count + 1); ($self -> verbose > 1) && $self -> log('id 2: ' . $session2 -> id); my($key) = $self -> key; my($data) = $session2 -> param($key); my($value) = $self -> value; ok($value eq $data, "Data stored (session1) and retrieved (session2)"); $self -> test_count($self -> test_count + 1); return $session2; } # End of test_session_from_id. # ----------------------------------------------- sub test_session_from_q { my($self, $session1) = @_; my($session3) = $self -> create_session_from_q($session1); isa_ok($session3, 'Data::Session', '3rd session object'); $self -> test_count($self -> test_count + 1); ($self -> verbose > 1) && $self -> log('id 3: ' . $session3 -> id); my($key) = $self -> key; my($data) = $session3 -> param($key); my($value) = $self -> value; ok($value eq $data, "Data stored (session1) and retrieved (session3)"); $self -> test_count($self -> test_count + 1); $key = "$key$key"; $data = $session3 -> param($key); ok("$value$value" eq $data, "More data stored (session1) and retrieved (session3)"); $self -> test_count($self -> test_count + 1); return $session3; } # End of test_session_from_q. # ----------------------------------------------- sub test_setting_getting_undef { my($self) = @_; my($key1) = 'stealth'; my($value1) = undef; my($key2) = 'null'; my($value2) = 'null'; my($session1) = $self -> create_session_from_scratch; $session1 -> param($key1 => $value1); $session1 -> param($key2 => $value2); $session1 -> flush; my($session2) = $self -> create_session_from_id($session1 -> id); ok(! defined $session2 -> param($key1), 'Stored and retrieved undef'); $self -> test_count($self -> test_count + 1); ok($session2 -> param($key2) eq $value2, "Stored and retrieved 'null'"); $self -> test_count($self -> test_count + 1); $session1 -> delete; $session2 -> delete; } # End of test_setting_getting_undef. # ----------------------------------------------- sub test_validation_of_time_strings { my($self) = @_; my(%map) = ( '-10' => -10, '+10d' => 864000, '10M' => 25920000, ); my($session) = $self -> create_session_from_scratch; my($count) = 0; my($seconds_in, $seconds_out); for my $time (qw/-10 +10d 10M/) { $count++; $seconds_in = $map{$time}; $seconds_out = $session -> validate_time($time); ok($seconds_in == $seconds_out, "Validated time string $time"); # This is not called, because we're running after the inner done_testing(). #$self -> test_count($self -> test_count + 1); } $session -> delete; # Return test count. return $count; } # End of test_validation_of_time_strings. # ----------------------------------------------- sub traverse { my($self) = @_; ($self -> verbose > 1) && $self -> dump; # Special code for SQLite. The table /must/ exist. # # However, for tests, we always re-create the table, although # users would not normally do this. The reason is that if a # test is for id:Static, serialize:DataDumper, and the next # test is for serialize::FreezeThaw, the static id means the # 2nd test uses the first id's data, which is in DataDumper format. # # For Files, skip, since we do not have database tables. if ($self -> type !~ /driver:File/) { # We rig it to use an id length of 32, since the table # is deleted and re-created below before being written to. $self -> setup_table(32); } my($session1) = $self -> create_session_from_scratch; isa_ok($session1, 'Data::Session', '1st session object'); $self -> test_count($self -> test_count + 1); $self -> log('id1: ' . $session1 -> id); # Stash ids for the traversal below. my(%id); $id{$session1 -> id} = 1; # For Files, skip, since we do not have database tables. if ($self -> type !~ /driver:File/) { # This time use the real length of the ID. $self -> setup_table($session1 -> id_class -> id_length); } # Create another 4 sessions, and then run a traverse(). for my $count (1 .. 4) { $session1 = $self -> create_session_from_scratch; $id{$session1 -> id} = 1; # Set some test data to play with. $session1 -> param($self -> key => $self -> value); $session1 -> flush; } my($count) = 0; my($sub) = sub { my($id) = @_; $count++; if ($id{$id}) { $self -> log("$count: Recovered known id $id from traverse"); } else { $self -> log("$count: Recovered unknown id $id from traverse"); } }; $session1 -> traverse($sub); } # End of traverse. # ----------------------------------------------- 1; Data-Session-1.18/t/00.versions.t0000644000175000017500000000236614012132245014632 0ustar ronron#/usr/bin/env perl use strict; use warnings; # I tried 'require'-ing modules but that did not work. use Data::Session; # For the version #. use Test::More; use autovivification; use CGI; use Class::Load; use Config::Tiny; use Data::Dumper; use Data::UUID; use DBD::SQLite; use DBI; use DBIx::Admin::CreateTable; use Digest::MD5; use Digest::SHA; use Fcntl; use File::Basename; use File::Path; use File::Slurper; use File::Spec; use File::Temp; use FreezeThaw; use Hash::FieldHash; use JSON; use overload; use parent; use Safe; use Scalar::Util; use Storable; use strict; use Try::Tiny; use vars; use warnings; use YAML::Tiny; # ---------------------- pass('All external modules loaded'); my(@modules) = qw / autovivification CGI Class::Load Config::Tiny Data::Dumper Data::UUID DBD::SQLite DBI DBIx::Admin::CreateTable Digest::MD5 Digest::SHA Fcntl File::Basename File::Path File::Slurper File::Spec File::Temp FreezeThaw Hash::FieldHash JSON overload parent Safe Scalar::Util Storable strict Try::Tiny vars warnings YAML::Tiny /; diag "Testing Data::Session V $Data::Session::VERSION"; for my $module (@modules) { no strict 'refs'; my($ver) = ${$module . '::VERSION'} || 'N/A'; diag "Using $module V $ver"; } done_testing; Data-Session-1.18/t/traverse.t0000644000175000017500000000554012657730604014414 0ustar ronron#!/usr/bin/env perl use strict; use warnings; use lib 't'; use Config::Tiny; use DBI; use File::Temp; use Test; use Test::More; use Try::Tiny; # ----------------------------------------------- sub BEGIN { use_ok('Data::Session'); } # ----------------------------------------------- sub run { my($id, $serializer, $config, $test_count) = @_; my(@dsn, $directory, $type); my($tester); try { # WTF: You cannot use DBI -> parse_dsn(...) || die $msg; # even though that's what the docs say to do. # BAIL_OUT reports (e.g.): ... Error in type: Unexpected component 'sha1' ... @dsn = DBI -> parse_dsn($$config{dsn}); if ($#dsn < 0) { die __PACKAGE__ . ". Can't parse dsn '$$config{dsn}'"; } # The EXLOCK option is for BSD-based systems. $directory = File::Temp::newdir('temp.XXXX', CLEANUP => 1, EXLOCK => 0, TMPDIR => 1); $type = "driver:$dsn[1];id:$id;serialize:$serializer"; $tester = Test -> new ( directory => $directory, dsn => $$config{dsn}, dsn_attr => $$config{attributes}, password => $$config{password}, type => $type, username => $$config{username}, verbose => 1, ); subtest $type => sub { $$test_count += $tester -> traverse; }; } catch { # This extra call to done_testing just stops an extra error message. done_testing($$test_count); BAIL_OUT($_); }; } # End of run. # ----------------------------------------------- sub report { my($s) = @_; print STDERR "# $s\n"; } # End of report. # ----------------------------------------------- sub string2hashref { my($s) = @_; $s ||= ''; my($result) = {}; if ($s) { if ($s =~ m/^\{\s*([^}]*)\}$/) { my(@attr) = map{split(/\s*=>\s*/)} split(/\s*,\s*/, $1); if (@attr) { $result = {@attr}; } } else { die "Invalid syntax for hashref: $s"; } } return $result; } # End of string2hashref. # ----------------------------------------------- my($dsn_config) = Config::Tiny -> read('t/basic.ini'); my($test_count) = 1; # The use_ok in BEGIN counts as the first test. my($config); my($temp); # We skip UUID16 since echoing such ids to the console can change the char set. for my $id (qw/MD5/) { for my $serializer (qw/DataDumper/) { for my $dsn_name (sort keys %$dsn_config) { $config = $$dsn_config{$dsn_name}; $$config{attributes} = string2hashref($$config{attributes}); next if ( ($$config{active} == 0) || ($$config{use_for_testing} == 0) ); $temp = Test -> new(dsn => $$config{dsn}, type => 'Fake'); if ($temp -> check_sqlite_directory_exists == 0) { report("Skipping dsn '$$config{dsn}' because the SQLite directory does not exist"); next; } report("DSN name: $dsn_name. DSN: $$config{dsn}. ID generator: $id. Serializer: $serializer"); run($id, $serializer, $config, \$test_count); } } } done_testing($test_count); Data-Session-1.18/t/bulk.ini0000644000175000017500000000126312657730604014030 0ustar ronron[BerkeleyDB.1] dsn = dbi:BerkeleyDB: active = 1 use_for_testing = 1 [File.1] dsn = dbi:File: active = 1 use_for_testing = 1 [memcached.1] dsn = dbi:Memcached: active = 1 use_for_testing = 1 [mysql.1] dsn = dbi:mysql:database=test username = testuser password = testpass attributes = {AutoCommit => 1, PrintError => 0, RaiseError => 1} active = 1 use_for_testing = 1 [Pg.1] dsn = dbi:Pg:dbname=test username = testuser password = testpass attributes = {AutoCommit => 1, PrintError => 0, RaiseError => 1} active = 1 use_for_testing = 1 [SQLite.1] dsn = dbi:SQLite:dbname=/tmp/sessions.sqlite attributes = {AutoCommit => 1, PrintError => 0, RaiseError => 1} active = 1 use_for_testing = 1 Data-Session-1.18/t/basic.ini0000644000175000017500000000126312657730604014154 0ustar ronron[BerkeleyDB.1] dsn = dbi:BerkeleyDB: active = 0 use_for_testing = 1 [File.1] dsn = dbi:File: active = 1 use_for_testing = 1 [memcached.1] dsn = dbi:Memcached: active = 0 use_for_testing = 1 [mysql.1] dsn = dbi:mysql:database=test username = testuser password = testpass attributes = {AutoCommit => 1, PrintError => 0, RaiseError => 1} active = 0 use_for_testing = 1 [Pg.1] dsn = dbi:Pg:dbname=test username = testuser password = testpass attributes = {AutoCommit => 1, PrintError => 0, RaiseError => 1} active = 0 use_for_testing = 1 [SQLite.1] dsn = dbi:SQLite:dbname=/tmp/sessions.sqlite attributes = {AutoCommit => 1, PrintError => 0, RaiseError => 1} active = 1 use_for_testing = 1 Data-Session-1.18/META.json0000644000175000017500000000463214012132256013535 0ustar ronron{ "abstract" : "Persistent session data management", "author" : [ "Ron Savage (ron@savage.net.au)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.58, CPAN::Meta::Converter version 2.150010", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Data-Session", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "CGI" : "3.63", "Class::Load" : "0.19", "Config::Tiny" : "2.14", "DBD::SQLite" : "1.39", "DBI" : "1.627", "DBIx::Admin::CreateTable" : "2.07", "Data::Dumper" : "2.145", "Data::UUID" : "1.218", "Digest::MD5" : "2.52", "Digest::SHA" : "5.84", "Fcntl" : "1.06", "File::Basename" : "2.77", "File::Path" : "2.07", "File::Slurper" : "0.012", "File::Spec" : "3.3", "File::Temp" : "0.22", "FreezeThaw" : "0.5001", "Hash::FieldHash" : "0.14", "JSON" : "2.59", "Safe" : "2.35", "Scalar::Util" : "1.27", "Storable" : "2.39", "Try::Tiny" : "0.12", "YAML::Tiny" : "1.51", "autovivification" : "0", "overload" : "0", "parent" : "0", "strict" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Test::More" : "1.001014", "Test::Pod" : "1.48" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/ronsavage/Data-Session/issues" }, "license" : [ "http://opensource.org/licenses/Artistic-2.0" ], "repository" : { "type" : "git", "url" : "https://github.com/ronsavage/Data-Session.git", "web" : "https://github.com/ronsavage/Data-Session" } }, "version" : "1.18", "x_serialization_backend" : "JSON::PP version 4.02" }