diff options
| author | Mason James <mtj@kohaaloha.com> | 2022-10-01 04:38:31 +1300 |
|---|---|---|
| committer | Mason James <mtj@kohaaloha.com> | 2022-10-01 04:38:31 +1300 |
| commit | 39673849416359984b1bc4704be6f0a68d23b801 (patch) | |
| tree | b8c90886e7c34d7a5e4fac6f22366de55da4c6ca | |
Import original source of Data-Session 1.18
56 files changed, 11411 insertions, 0 deletions
diff --git a/Changelog.ini b/Changelog.ini new file mode 100644 index 0000000..27b4042 --- /dev/null +++ b/Changelog.ini @@ -0,0 +1,201 @@ +[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= <<EOT +- Adopt new repo structure. See +http://savage.net.au/Ron/html/My.Workflow.for.Building.Distros.html. +- Replace File::Slurp with File::Slurper to help fix CPAN Tester error reports. +- Use File::Temp to replace hard-coded occurances of /tmp in t/*.ini. This is in response +to reports from CPAN Testers. +- Reformat Makefile.PL, and update bugtracker to github. +- Switch from the Artistic licence to the Perl one. +EOT + +[V 1.17] +Date=2015-02-14T09:38:00 +Comments= <<EOT +- Fix a bug in Data::Session.get_my_drivers(). See RT#111844. Many thanx to Slaven Rezic +for the report, diagnosis and patch. +- Add github repo https://github.com/ronsavage/Data-Session.git. +- Reformat the dates in this file, and hence in Changelog.ini from - e.g. - +'Mon Feb 8 08:45:00 2015' to what you see above. +- Reformat lines in this file, and in the docs, to be no more that 100 chars long. +- Move t/pod.t into xt/authors. +EOT + +[V 1.16] +Date=2014-04-03T17:53:00 +Comments= <<EOT +- Rewrite a bit of code which used 'each', to not update the hash being processed, because +'each' gets confused. See http://blogs.perl.org/users/rurban/2014/04/do-not-use-each.html. +Thanx to Reini Urban for that article. +EOT + +[V 1.15] +Date=2013-06-21T11:43:00 +Comments= <<EOT +- Update pre-reqs thus: Pragmas shipped with Perl are now version 0 only. This means they are +expected to be present, but a specific version # is not important. As per advice by +Father C. (for a different module). Pragmas affected: autovivification, overload, parent, +strict, vars and warnings. +- Update various other module version pre-reqs, including CGI to V 3.63. The test for equality +in t/basic.t for CGI cookies and HTTP header failed on CGI V 3.53, and work has been done +in CGI V 3.63 in that area. Hopefully this pre-req change fixes that problem (which was +detected on 1 CPAN Tester machine). +EOT + +[V 1.14] +Date=2013-06-19T17:07:00 +Comments= <<EOT +- No code changes. +- Rename CHANGES to Changes as per CPAN::Changes::SPEC. +- Update pre-reqs. +EOT + +[V 1.13] +Date=2012-05-03T11:23:00 +Comments= <<EOT +- In parse_options(), the result of parsing the 'type' (driver:Pg;id:MD5;serialize:DataDumper) +was printed both for verbose == 1 and verbose > 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= <<EOT +- 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. +EOT + +[V 1.11] +Date=2011-07-08T11:17:00 +Comments= <<EOT +- 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. +EOT + +[V 1.10] +Date=2011-06-21T16:42:00 +Comments= <<EOT +- 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. +EOT + +[V 1.09] +Date=2011-06-17T14:22:00 +Comments= <<EOT +- 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. +EOT + +[V 1.08] +Date=2011-06-17T13:07:00 +Comments=- Ensure new sessions, and not just modified ones, are written during flush(). + +[V 1.07] +Date=2011-05-16T09:23:00 +Comments= <<EOT +- Remove redundant declaration of id() in Data::Session::ID::Static, which was producing the +message: field "id" redefined or overridden at ... line 10. +EOT + +[V 1.06] +Date=2011-05-12T12:01:00 +Comments= <<EOT +- 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. +EOT + +[V 1.05] +Date=2011-04-12T13:11:00 +Comments= <<EOT +- 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. +EOT + +[V 1.04] +Date=2011-02-16T11:55:00 +Comments= <<EOT +- Replace /usr/bin/perl with /usr/bin/env perl. +- Replace common::sense with use strict and use warnings, to get uninit var warnings. +EOT + +[V 1.03] +Date=2010-12-24T17:36:00 +Comments= <<EOT +- 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 +EOT + +[V 1.02] +Date=2010-12-14T11:16:00 +Comments= <<EOT +- 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. +EOT + +[V 1.01] +Date=2010-12-01T16:35:00 +Comments= <<EOT +- In t/basic.t, use Module::Load to load BerkeleyDB and Cache::Memcache conditionally, and exit +cleanly if they are not installed. +EOT + +[V 1.00] +Date=2010-11-30T14:08:00 +Comments=- Original version. @@ -0,0 +1,145 @@ +Revision history for Perl extension Data::Session. + +1.18 2017-08-14T11:13:00 + - Adopt new repo structure. See + http://savage.net.au/Ron/html/My.Workflow.for.Building.Distros.html. + - Replace File::Slurp with File::Slurper to help fix CPAN Tester error reports. + - Use File::Temp to replace hard-coded occurances of /tmp in t/*.ini. This is in response + to reports from CPAN Testers. + - Reformat Makefile.PL, and update bugtracker to github. + - Switch from the Artistic licence to the Perl one. + +1.17 2015-02-14T09:38:00 + - Fix a bug in Data::Session.get_my_drivers(). See RT#111844. Many thanx to Slaven Rezic + for the report, diagnosis and patch. + - Add github repo https://github.com/ronsavage/Data-Session.git. + - Reformat the dates in this file, and hence in Changelog.ini from - e.g. - + 'Mon Feb 8 08:45:00 2015' to what you see above. + - Reformat lines in this file, and in the docs, to be no more that 100 chars long. + - Move t/pod.t into xt/authors. + +1.16 2014-04-03T17:53:00 + - Rewrite a bit of code which used 'each', to not update the hash being processed, because + 'each' gets confused. See http://blogs.perl.org/users/rurban/2014/04/do-not-use-each.html. + Thanx to Reini Urban for that article. + +1.15 2013-06-21T11:43:00 + - Update pre-reqs thus: Pragmas shipped with Perl are now version 0 only. This means they are + expected to be present, but a specific version # is not important. As per advice by + Father C. (for a different module). Pragmas affected: autovivification, overload, parent, + strict, vars and warnings. + - Update various other module version pre-reqs, including CGI to V 3.63. The test for equality + in t/basic.t for CGI cookies and HTTP header failed on CGI V 3.53, and work has been done + in CGI V 3.63 in that area. Hopefully this pre-req change fixes that problem (which was + detected on 1 CPAN Tester machine). + +1.14 2013-06-19T17:07:00 + - No code changes. + - Rename CHANGES to Changes as per CPAN::Changes::SPEC. + - Update pre-reqs. + +1.13 2012-05-03T11:23:00 + - In parse_options(), the result of parsing the 'type' (driver:Pg;id:MD5;serialize:DataDumper) + was printed both for verbose == 1 and verbose > 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.
\ No newline at end of file @@ -0,0 +1,378 @@ +Terms 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 + + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..ef843c1 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,56 @@ +Changelog.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) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..1bde9eb --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,47 @@ +# 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-.* diff --git a/META.json b/META.json new file mode 100644 index 0000000..f6b7e8e --- /dev/null +++ b/META.json @@ -0,0 +1,90 @@ +{ + "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" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7939ae0 --- /dev/null +++ b/META.yml @@ -0,0 +1,58 @@ +--- +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' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..9f89fab --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,101 @@ +use 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); @@ -0,0 +1,49 @@ +README 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 diff --git a/lib/Data/Session.pm b/lib/Data/Session.pm new file mode 100644 index 0000000..0035c69 --- /dev/null +++ b/lib/Data/Session.pm @@ -0,0 +1,2672 @@ +package 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 <<EOS; + <html> + <head><title>$title</title></head> + <body> + Number of times this script has been run: $count.<br/> + Current value of $name: $id.<br/> + <form id='sample' method='post' name='sample'> + <button id='submit'>Click to submit</button> + <input type='hidden' name='$name' id='$name' value='$id' /> + </form> + </body> + </html> + 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</Test Code>. + +=head1 Description + +L<Data::Session> 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<Data::Session::CGISession> for an extended discussion of the design changes between +L<Data::Session> and L<CGI::Session>. + +L<Data::Session> 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</flush()>. + +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<Data::Session>, or - if new() fails - it returns undef. +For details see L</Trouble with Errors>. + +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</Synopsis> for +example code. + +The questions of combinations of options, and which option has priority over other options, +are addressed in the section, L</Combinations of Options>. + +=over 4 + +=item o cache => $cache + +Specifies an object of type L<BerkeleyDB> or L<Cache::Memcached> to use for storage. + +Only needed if you use 'type' like 'driver:BerkeleyDB ...' or 'driver:Memcached ...'. + +See L<Data::Session::Driver::BerkeleyDB> and L<Data::Session::Driver::Memcached>. + +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<DBI>'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<DBI>'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<Data::Session::File::Driver> and +L<Data::Session::ID::AutoIncrement>. + +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<File::Spec>. + +See L</Specifying Session Options> 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</Specifying Session Options> 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</user_id()> 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<Specifying an Id>. + +=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<Data::Session::ID::AutoIncrement> 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<id_base + +id_step>, 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<Data::Session::Driver::File>). + +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</Specifying an Id> and L</user_id()>. + +=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<DBI>'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</Combinations of Options> 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</Combinations of Options> 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<Data::Session> 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</Specifying Session Options>. + +=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<DBI>'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</dump([$heading])> for what happens when verbose is 2. + +=back + +=head3 Specifying Session Options + +See also L</Case-sensitive Options>. + +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<BerkeleyDB> for storage. In this case, you must pass an object of type L<BerkeleyDB> +to new() as the value of the 'cache' option. + +See L<Data::Session::Driver::BerkeleyDB>. + +=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<File::Spec> 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<Data::Session::Driver::File>. + +=item o Memcached + +Use C<memcached> for storage. In this case, you must pass an object of type L<Cache::Memcached> to +new() as the value of the 'cache' option. + +See L<Data::Session::Driver::Memcached>. + +=item o mysql + +This says each session is stored in a separate row of a database table using the L<DBD::mysql> +database server. + +These rows have a unique primary id equal to the session id. + +See L<Data::Session::Driver::mysql>. + +=item o ODBC + +This says each session is stored in a separate row of a database table using the L<DBD::ODBC> +database connector. + +These rows have a unique primary id equal to the session id. + +See L<Data::Session::Driver::ODBC>. + +=item o Oracle + +This says each session is stored in a separate row of a database table using the L<DBD::Oracle> +database server. + +These rows have a unique primary id equal to the session id. + +See L<Data::Session::Driver::Oracle>. + +=item o Pg + +This says each session is stored in a separate row of a database table using the L<DBD::Pg> database +server. + +These rows have a unique primary id equal to the session id. + +See L<Data::Session::Driver::Pg>. + +=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<and server> are shipped with all recent versions of Perl. + +See L<Data::Session::Driver::SQLite>. + +=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<not> 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<Data::Session::ID::AutoIncrement>. + +=item o MD5 + +The default, 'MD5', says ids are to be generated by L<Digest::MD5>. + +See L<Data::Session::ID::MD5>. + +=item o SHA1 + +This says ids are to be generated by L<Digest::SHA>, using a digest algorithm of 1. + +See L<Data::Session::ID::SHA1>. + +=item o SHA256 + +This says ids are to be generated by L<Digest::SHA>, using a digest algorithm of 256. + +See L<Data::Session::ID::SHA256>. + +=item o SHA512 + +This says ids are to be generated by L<Digest::SHA>, using a digest algorithm of 512. + +See L<Data::Session::ID::SHA512>. + +=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<Data::Session> dies on all values Perl regards as +false. + +See L<Data::Session::ID::Static>. + +=item o UUID16 + +This says ids are to be generated by L<Data::UUID>, to generate a 16 byte long binary UUID. + +See L<Data::Session::ID::UUID16>. + +=item o UUID34 + +This says ids are to be generated by L<Data::UUID>, to generate a 34 byte long string UUID. + +See L<Data::Session::ID::UUID34>. + +=item o UUID36 + +This says ids are to be generated by L<Data::UUID>, to generate a 36 byte long string UUID. + +See L<Data::Session::ID::UUID36>. + +=item o UUID64 + +This says ids are to be generated by L<Data::UUID>, to generate a 24 (sic) byte long, base-64 +encoded, UUID. + +See L<Data::Session::ID::UUID64>. + +=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<Data::Dumper> to freeze/thaw sessions. + +See L<Data::Session::Serialize::DataDumper>. + +=item o FreezeThaw + +Use L<FreezeThaw> to freeze/thaw sessions. + +See L<Data::Session::Serialize::FreezeThaw>. + +=item o JSON + +Use L<JSON> to freeze/thaw sessions. + +See L<Data::Session::Serialize::JSON>. + +=item o Storable + +Use L<Storable> to freeze/thaw sessions. + +See L<Data::Session::Serialize::Storable>. + +Warning: Storable should be avoided until this problem is fixed: +L<http://rt.cpan.org/Public/Bug/Display.html?id=36087>. + +=item o YAML + +Use L<YAML::Tiny> to freeze/thaw sessions. + +See L<Data::Session::Serialize::YAML>. + +=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<Data::Session::Driver::BerkeleyDB> + +This name comes from L<BerkeleyDB>. + +And yes, the module uses L<BerkeleyDB> and not L<DB_File>. + +=item o L<Data::Session::Driver::File> + +=item o L<Data::Session::Driver::Memcached> + +This name comes from L<Cache::Memcached> even though the external program you run is called +memcached. + +=item o L<Data::Session::Driver::mysql> + +=item o L<Data::Session::Driver::ODBC> + +=item o L<Data::Session::Driver::Oracle> + +=item o L<Data::Session::Driver::Pg> + +=item o L<Data::Session::Driver::SQLite> + +=back + +ID generators: + +=over 4 + +=item o L<Data::Session::ID::AutoIncrement> + +=item o L<Data::Session::ID::MD5> + +=item o L<Data::Session::ID::SHA1> + +=item o L<Data::Session::ID::SHA256> + +=item o L<Data::Session::ID::SHA512> + +=item o L<Data::Session::ID::Static> + +=item o L<Data::Session::ID::UUID16> + +=item o L<Data::Session::ID::UUID34> + +=item o L<Data::Session::ID::UUID36> + +=item o L<Data::Session::ID::UUID64> + +=back + +Serializers: + +=over 4 + +=item o L<Data::Session::Serialize::DataDumper> + +=item o L<Data::Session::Serialize::FreezeThaw> + +=item o L<Data::Session::Serialize::JSON> + +=item o L<Data::Session::Serialize::Storable> + +Warning: Storable should be avoided until this problem is fixed: +L<http://rt.cpan.org/Public/Bug/Display.html?id=36087> + +=item o L<Data::Session::Serialize::YAML> + +=back + +=head3 Specifying an Id + +L</user_id()> 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</Specifying Session Options>, 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:<Not AutoIncrement>;...'), 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</load_session()>. + +See also L</ctime()>, L</etime()> and L</ptime()>. + +=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</delete()> for precisely what this means. + +=item o Sets the expired flag + +See L</expired()>. + +=back + +This is used when the session is loaded, when you call L</http_header([@arg])>, 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</param([@arg])> 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<Data::Session>, and hence should I<not> be passed in, +are: + +=over 4 + +=item o -expires + +=item o -name + +=item o -value + +=back + +See L</http_header([@arg])> 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<object>, except for new sessions. + +See also L</atime()>, L</etime()> and L</ptime()>. + +=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</deleted()> and L</expire([@arg])>. + +=head2 deleted() + +Returns a Boolean (0/1) indicating whether or not the session has been deleted. + +See also L</delete()> and L</expire([@arg])>. + +=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<Test::More> 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</atime()>, L</ctime()> and L</ptime()>. + +=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<Cache::Memcached>. See below and L<Data::Session::Driver::Memcached>. + +When a session expires, it is deleted from storage. See L</delete()> 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</clear([$name])> +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</validate_time($time)> 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<Cache::Memcached>. 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</atime()>, L</ctime()>, L</etime()>, L</delete()> and +L</deleted()>. + +=head2 expired() + +Returns a Boolean (0/1) indicating whether or not the session has expired. + +See L</delete()>. + +=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</Trouble with Exiting> 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<Cache::Memcached>. See L</expire([@arg])> and +L<Data::Session::Driver::Memcached>. + +=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<not> print the header. You have to do that, when +appropriate. + +Unlike L<CGI::Session>, L<Data::Session> does I<not> 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<CGI> and L<CGI::Simple> default to 'text/html'. + +L<Data::Session> 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</save_param([$q][, $name])> 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<CGI::Session>. + +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</clear([$name])>. + +=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</expire([@arg])>. + +See also L</atime()>, L</ctime()> and L</etime()>. + +=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</load_param([$q][, $name])> 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</expire([@arg])> 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<BerkeleyDB> (Oracle and Perl) are in +L<Data::Session::Driver::Berkeley>. + +Simple instructions for installing L<Cache::Memcached> and memcached are in +L<Data::Session::Driver::Memcached>. + +=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<CGI::Snapp> have a I<param()> method + +Let's say your L<CGI> script sub-classes L<CGI::Application> or it's successor L<CGI::Snapp>. + +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<param()>. Basically, you're storing a value +(via 'param') inside $self. + +But when you store an object of type Data::Session using I<param()>, it looks like this: + + $self -> param(session => Data::Session -> new(...) ); + +Now, Data::Session itself I<also> implements a method called I<param()>. 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<param()> methods. + +=item o 2: How exactly should a L<CGI> script save a session? + +The first example in the Synopsis shows a very simple L<CGI> script doing the right thing by +calling I<flush()> just before it exits. + +Alternately, if you sub-class L<CGI::Snapp>, the call to I<flush()> is best placed in your +I<teardown()> method, which is where you override L<CGI::Snapp/teardown()>. The point here is that +your I<teardown()> is called automatically at the end of each run mode. + +This important matter is also discussed in L</General Questions> 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</Trouble with Exiting>, below, to understand why flush() must be called explicitly in +persistent environments. + +=item o Why don't the test scripts use L<Test::Database>? + +I decided to circumvent it by using L<DBIx::Admin::DSNManager> and adopting the wonders of nested +testing. But, since V 1.11, I've replaced that module with L<Config::Tiny>, to reduce dependencies, +and hence to make it easier to get L<Data::Session> 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<CGI::Session::ID::uuid>? + +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<Data::Session>) +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<flush()> 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<CGI> or similar, but you don't pass that object into +L<Data::Session> 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<Data::Session>. + +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<Data::Session> 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<Plack>, 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<Devel::Cycle> before assuming the fault is with L<Data::Session>. + +=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<https://github.com/ronsavage/Data-Session.git> + +=head1 Support + +LBugs should be reported via the CPAN bug tracker at + +L<https://github.com/ronsavage/Data-Session/issues> + +=head1 Thanks + +Many thanks are due to all the people who contributed to both L<Apache::Session> and +L<CGI::Session>. + +Likewise, many thanks to the implementors of nesting testing. See L<Test::Simple>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Base.pm b/lib/Data/Session/Base.pm new file mode 100644 index 0000000..056b304 --- /dev/null +++ b/lib/Data/Session/Base.pm @@ -0,0 +1,114 @@ +package 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<Data::Session::Base> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/CGISession.pm b/lib/Data/Session/CGISession.pm new file mode 100644 index 0000000..e5870d0 --- /dev/null +++ b/lib/Data/Session/CGISession.pm @@ -0,0 +1,440 @@ +package Data::Session::CGISession; + +our $VERSION = '1.18'; + +# ----------------------------------------------- + +1; + +=pod + +=head1 NAME + +L<Data::Session> - 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<Apache::Session> and L<CGI::Session>. + +The interface to L<Data::Session> is not quite compatible with that of L<CGI::Session>, hence the +new namespace. + +The purpose of L<Data::Session> is to be a brand-new alternative to both L<Apache::Session> and +L<CGI::Session>. + +=head1 Aliases for Method Names + +Aliases for method names are not supported. + +In L<CGI::Session>, methods etime() and expires() were aliased to expire(). This is not supported +in L<Data::Session>. + +L<Data::Session> does have an etime() method, L<Data::Session/Method: etime()>, which is different. + +In L<CGI::Session>, method header() was aliased to http_header(). Only the latter method is +supported in L<Data::Session>. See L</Method: cookie()> and L</Method: http_header([@arg])>. + +In L<CGI::Session>, id generators had a method generate_id() aliased to generate(). This is not +supported in L<Data::Session>. + +In L<CGI::Session>, method param_dataref() was aliased to dataref(). Neither of these methods is +supported in L<Data::Session>. 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<Data::Session> is not I<exactly> backwards-compatible with L<CGI::Session>, 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<Data::Session/Specifying Session Options> 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<CGI::Session>, persistent environments stop your program exiting in the way +you are used to. This matter is discussed in L<Data::Session/Trouble with Exiting>. + +=back + +=head1 CGI::Session::ExpireSessions is obsolete + +Instead, consider using scripts/expire.pl, which ships with L<Data::Session>. + +=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<Data::Session> 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<Text::Abbrev>. 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</ID Generators>, L</Serialization Drivers> and +L</Storage Drivers>. + +For example, driver:pg is now driver:Pg, which actually means L<Data::Session::Driver::Pg>, based on +the class name L<DBD::Pg>. + +=head1 Exceptions + +Exceptions are caught with L<Try::Tiny>. Errors cause L<Data::Session> 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<Data::Session::ID::AutoIncrement> + +=item o CGI::Session::ID::md5 becomes L<Data::Session::ID::MD5> + +=item o CGI::Session::ID::sha becomes L<Data::Session::ID::SHA1> + +=item o CGI::Session::ID::sha256 becomes L<Data::Session::ID::SHA256> + +=item o CGI::Session::ID::sha512 becomes L<Data::Session::ID::SHA512> + +=item o CGI::Session::ID::static becomes L<Data::Session::ID::Static> + +=item o CGI::Session::ID::uuid becomes L<Data::Session::ID::UUID16> or UUID34 or UUID36 or UUD64 + +=back + +=head1 JSON + +L<Data::Session::Serialize::JSON> uses L<JSON>, not L<JSON::Syck>. + +=head2 Managing Object Attributes + +The light-weight L<Hash::FieldHash> is used to manage object attributes. + +So, neither L<Mouse> nor L<Moose>, 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</Method: http_header([@arg])>. + +=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<CGI> and L<CGI::Simple> default to 'text/html'. + +L<Data::Session> 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</ID Generators>, L</Serialization Drivers> and +L</Storage Drivers>. + +As discussed in L<Data::Session/Method: new()>, 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<CGI::Session::Driver::postgresql> has been incorporated into other +L<Data::Session::Driver::*> drivers. + +=head1 Serialization Drivers + +Serializing classes have been renamed: + +=over 4 + +=item o CGI::Session::Serialize::default becomes L<Data::Session::Serialize::DataDumper> + +=item o CGI::Session::Serialize::freezethaw becomes L<Data::Session::Serialize::FreezeThaw> + +=item o CGI::Session::Serialize::json becomes L<Data::Session::Serialize::JSON> + +The latter will use L<JSON>. In the past L<JSON::Syck> was used. + +=item o CGI::Session::Serialize::storable becomes L<Data::Session::Serialize::Storable> + +=item o CGI::Session::Serialize::yaml becomes L<Data::Session::Serialize::YAML> + +The latter uses L<YAML::Tiny>. In the past either L<YAML::Syck> or L<YAML> 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<Data::Session> 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<Data::Session/Specifying an Id> for details. + +=head1 Session modification + +L<CGI::Session> 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<CGI::Session> 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<Data::Session> 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<Data::Session> 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<CGI::Session> 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<Data::Session::Driver::BerkeleyDB> + +The latter no longer uses DB_File. + +=item o CGI::Session::Driver::file becomes L<Data::Session::Driver::File> + +=item o CGI::Session::Driver::memcached becomes L<Data::Session::Driver::Memcached> + +=item o CGI::Session::Driver::mysql becomes L<Data::Session::Driver::mysql> + +=item o CGI::Session::Driver::odbc becomes L<Data::Session::Driver::ODBC> + +=item o CGI::Session::Driver::oracle becomes L<Data::Session::Driver::Oracle> + +=item o CGI::Session::Driver::postgresql becomes L<Data::Session::Driver::Pg> + +=item o CGI::Session::Driver::sqlite becomes L<Data::Session::Driver::SQLite> + +=back + +=head1 Tests + +All tests have been re-written. + +=head1 The Version of Perl + +Perl 5 code will be used. + +=head1 YAML + +L<Data::Session::Serialize::YAML> uses L<YAML::Tiny>, not L<YAML::Syck> or L<YAML>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver.pm b/lib/Data/Session/Driver.pm new file mode 100644 index 0000000..a50cf83 --- /dev/null +++ b/lib/Data/Session/Driver.pm @@ -0,0 +1,224 @@ +package 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<Data::Session::Driver> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver> is the parent of all L<Data::Session::Driver::*> modules. + +=head1 Case-sensitive Options + +See L<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver>. + +C<new()> 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<Data::Session> calls the right thaw() automatically. + +=head1 Support + +Log a bug on RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver/BerkeleyDB.pm b/lib/Data/Session/Driver/BerkeleyDB.pm new file mode 100644 index 0000000..62df962 --- /dev/null +++ b/lib/Data/Session/Driver/BerkeleyDB.pm @@ -0,0 +1,260 @@ +package 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<Data::Session::Driver::BerkeleyDB> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver::BerkeleyDB> allows L<Data::Session> to manipulate sessions via +L<BerkeleyDB>. + +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<BerkeleyDB> as Data::Session -> new(cache => $object) + +Also, $object must have been created with a Env parameter of type L<BerkeleyDB::Env>. See below. + +=back + +See scripts/berkeleydb.pl. + +=head1 Case-sensitive Options + +See L<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver::BerkeleyDB>. + +C<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. + +=over 4 + +=item o cache => $object + +Specifies the object of type L<BerkeleyDB> 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<BerkeleyDB>, and with +that object having an Env parameter of type L<Berkeley::Env>, because this module - +L<Data::Session::Driver::BerkeleyDB> - uses the L<BerkeleyDB> 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<BerkeleyDB> 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<BerkeleyDB> method get($id). + +This result is a frozen session. This value must be thawed by calling the appropriate serialization +driver's thaw() method. + +L<Data::Session> 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<BerkeleyDB> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver/File.pm b/lib/Data/Session/Driver/File.pm new file mode 100644 index 0000000..8f8a713 --- /dev/null +++ b/lib/Data/Session/Driver/File.pm @@ -0,0 +1,379 @@ +package 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<Data::Session::Driver::File> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver::File> allows L<Data::Session> 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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver::File>. + +C<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. + +=over 4 + +=item o debug => $Boolean + +Specifies that debugging should be turned on (1) or off (0) in L<Data::Session::File::Driver> and +L<Data::Session::ID::AutoIncrement>. + +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<Data::Session> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver/Memcached.pm b/lib/Data/Session/Driver/Memcached.pm new file mode 100644 index 0000000..0322d3a --- /dev/null +++ b/lib/Data/Session/Driver/Memcached.pm @@ -0,0 +1,227 @@ +package 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<Data::Session::Driver::Memcached> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver::Memcached> allows L<Data::Session> to manipulate sessions +L<Cache::Memcached>. + +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<Cache::Memcached> as Data::Session -> new(cache => $object) + +=back + +See scripts/memcached.pl. + +=head1 Case-sensitive Options + +See L<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver::Memcached>. + +C<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. + +=over 4 + +=item o cache => $object + +Specifies the object of type L<Cache::Memcached> 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<Cache::Memcached> 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<Cache::Memcached> method get($id). + +This result is a frozen session. This value must be thawed by calling the appropriate serialization +driver's thaw() method. + +L<Data::Session> 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<Cache::Memcached>, too. + +Returns the result of calling the L<Cache::Memcached> 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<Cache::Memcached> documentation, you will have to subclass L<Cache::Memcached> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver/ODBC.pm b/lib/Data/Session/Driver/ODBC.pm new file mode 100644 index 0000000..e8b710a --- /dev/null +++ b/lib/Data/Session/Driver/ODBC.pm @@ -0,0 +1,269 @@ +package 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<Data::Session::Driver::ODBC> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver::ODBC> allows L<Data::Session> to store sessions via L<DBD::ODBC>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver::ODBC>. + +C<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. + +=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<Data::Session> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver/Oracle.pm b/lib/Data/Session/Driver/Oracle.pm new file mode 100644 index 0000000..4ebca21 --- /dev/null +++ b/lib/Data/Session/Driver/Oracle.pm @@ -0,0 +1,269 @@ +package 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<Data::Session::Driver::Oracle> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver::Oracle> allows L<Data::Session> to store sessions via L<DBD::Oracle>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver::Oracle>. + +C<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. + +=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<Data::Session> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver/Pg.pm b/lib/Data/Session/Driver/Pg.pm new file mode 100644 index 0000000..02e5923 --- /dev/null +++ b/lib/Data/Session/Driver/Pg.pm @@ -0,0 +1,363 @@ +package 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<Data::Session::Driver::Pg> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver::Pg> allows L<Data::Session> to manipulate sessions via L<DBD::Pg>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver::Pg>. + +C<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. + +=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<Data::Session> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver/SQLite.pm b/lib/Data/Session/Driver/SQLite.pm new file mode 100644 index 0000000..90a261c --- /dev/null +++ b/lib/Data/Session/Driver/SQLite.pm @@ -0,0 +1,330 @@ +package 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<Data::Session::Driver::SQLite> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver::SQLite> allows L<Data::Session> to manipulate sessions via L<DBD::SQLite>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver::SQLite>. + +C<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. + +=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<Data::Session> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Driver/mysql.pm b/lib/Data/Session/Driver/mysql.pm new file mode 100644 index 0000000..2db39ba --- /dev/null +++ b/lib/Data/Session/Driver/mysql.pm @@ -0,0 +1,296 @@ +package 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<Data::Session::Driver::mysql> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Driver::mysql> allows L<Data::Session> to manipulate sessions via L<DBD::mysql>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Driver::mysql>. + +C<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. + +=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<Data::Session> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID.pm b/lib/Data/Session/ID.pm new file mode 100644 index 0000000..cfedc52 --- /dev/null +++ b/lib/Data/Session/ID.pm @@ -0,0 +1,75 @@ +package 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<Data::Session::ID> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID> is the parent of all L<Data::Session::ID::*> modules. + +=head1 Case-sensitive Options + +See L<Data::Session/Case-sensitive Options> for important information. + +=head1 Support + +Log a bug on RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/AutoIncrement.pm b/lib/Data/Session/ID/AutoIncrement.pm new file mode 100644 index 0000000..974047a --- /dev/null +++ b/lib/Data/Session/ID/AutoIncrement.pm @@ -0,0 +1,221 @@ +package 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<Data::Session::ID::AutoIncrement> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::AutoIncrement> allows L<Data::Session> 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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::AutoIncrement>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/MD5.pm b/lib/Data/Session/ID/MD5.pm new file mode 100644 index 0000000..34b0e69 --- /dev/null +++ b/lib/Data/Session/ID/MD5.pm @@ -0,0 +1,137 @@ +package 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<Data::Session::ID::MD5> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::MD5> allows L<Data::Session> to generate session ids using L<Digest::MD5>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::MD5>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/SHA1.pm b/lib/Data/Session/ID/SHA1.pm new file mode 100644 index 0000000..7a40c38 --- /dev/null +++ b/lib/Data/Session/ID/SHA1.pm @@ -0,0 +1,130 @@ +package 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<Data::Session::ID::SHA1> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::SHA1> allows L<Data::Session> to generate session ids using L<Digest::SHA>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::SHA1>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/SHA256.pm b/lib/Data/Session/ID/SHA256.pm new file mode 100644 index 0000000..048e34d --- /dev/null +++ b/lib/Data/Session/ID/SHA256.pm @@ -0,0 +1,132 @@ +package 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<Data::Session::ID::SHA256> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::SHA256> allows L<Data::Session> to generate session ids using L<Digest::SHA>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::SHA256>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/SHA512.pm b/lib/Data/Session/ID/SHA512.pm new file mode 100644 index 0000000..500b2d7 --- /dev/null +++ b/lib/Data/Session/ID/SHA512.pm @@ -0,0 +1,132 @@ +package 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<Data::Session::ID::SHA512> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::SHA512> allows L<Data::Session> to generate session ids using L<Digest::SHA>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::SHA512>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/Static.pm b/lib/Data/Session/ID/Static.pm new file mode 100644 index 0000000..0697923 --- /dev/null +++ b/lib/Data/Session/ID/Static.pm @@ -0,0 +1,145 @@ +package 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<Data::Session::ID::Static> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::Static> allows L<Data::Session> 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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::Static>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/UUID16.pm b/lib/Data/Session/ID/UUID16.pm new file mode 100644 index 0000000..f007046 --- /dev/null +++ b/lib/Data/Session/ID/UUID16.pm @@ -0,0 +1,156 @@ +package 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<Data::Session::ID::UUID16> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Case-sensitive Options + +See L<Data::Session/Case-sensitive Options> 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<Data::Session::ID::UUID16> allows L<Data::Session> to generate session ids using L<Data::UUID>. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::UUID16>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/UUID34.pm b/lib/Data/Session/ID/UUID34.pm new file mode 100644 index 0000000..bc25188 --- /dev/null +++ b/lib/Data/Session/ID/UUID34.pm @@ -0,0 +1,149 @@ +package 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<Data::Session::ID::UUID34> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::UUID34> allows L<Data::Session> to generate session ids using L<Data::UUID>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::UUID34>. + +C<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. + +=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<Data::UUID> 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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/UUID36.pm b/lib/Data/Session/ID/UUID36.pm new file mode 100644 index 0000000..0a33769 --- /dev/null +++ b/lib/Data/Session/ID/UUID36.pm @@ -0,0 +1,147 @@ +package 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<Data::Session::ID::UUID36> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::UUID36> allows L<Data::Session> to generate session ids using L<Data::UUID>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::UUID36>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/ID/UUID64.pm b/lib/Data/Session/ID/UUID64.pm new file mode 100644 index 0000000..794b60d --- /dev/null +++ b/lib/Data/Session/ID/UUID64.pm @@ -0,0 +1,154 @@ +package 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<Data::Session::ID::UUID64> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::ID::UUID64> allows L<Data::Session> to generate session ids using L<Data::UUID>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::ID::UUID64>. + +C<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. + +=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<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/SHA.pm b/lib/Data/Session/SHA.pm new file mode 100644 index 0000000..f0b0a58 --- /dev/null +++ b/lib/Data/Session/SHA.pm @@ -0,0 +1,77 @@ +package 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<Data::Session::SHA> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::SHA> is the parent of all L<Data::Session::SHA::*> modules. + +=head1 Case-sensitive Options + +See L<Data::Session/Case-sensitive Options> for important information. + +=head1 Support + +Log a bug on RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Serialize/DataDumper.pm b/lib/Data/Session/Serialize/DataDumper.pm new file mode 100644 index 0000000..475c01a --- /dev/null +++ b/lib/Data/Session/Serialize/DataDumper.pm @@ -0,0 +1,265 @@ +package 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<Data::Session::Serialize::DataDumper> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Serialize::DataDumper> allows L<Data::Session> to manipulate sessions with +L<Data::Dumper>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Serialize::DataDumper>. + +C<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. + +=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<Data::Dumper>. + +=head1 Method: thaw($data) + +Returns $data thawed by L<Data::Dumper>. + +=head1 Support + +Log a bug on RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Serialize/FreezeThaw.pm b/lib/Data/Session/Serialize/FreezeThaw.pm new file mode 100644 index 0000000..aa5b42d --- /dev/null +++ b/lib/Data/Session/Serialize/FreezeThaw.pm @@ -0,0 +1,127 @@ +package 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<Data::Session::Serialize::FreezeThaw> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Serialize::FreezeThaw> allows L<Data::Session> to manipulate sessions with +L<FreezeThaw>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Serialize::FreezeThaw>. + +C<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. + +=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<FreezeThaw>. + +=head1 Method: thaw($data) + +Returns $data thawed by L<FreezeThaw>. + +=head1 Support + +Log a bug on RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Serialize/JSON.pm b/lib/Data/Session/Serialize/JSON.pm new file mode 100644 index 0000000..e6192fa --- /dev/null +++ b/lib/Data/Session/Serialize/JSON.pm @@ -0,0 +1,125 @@ +package 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<Data::Session::Serialize::JSON> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Serialize::JSON> allows L<Data::Session> to manipulate sessions with L<JSON>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Serialize::JSON>. + +C<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. + +=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<JSON>. + +=head1 Method: thaw($data) + +Returns $data thawed by L<JSON>. + +=head1 Support + +Log a bug on RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Serialize/Storable.pm b/lib/Data/Session/Serialize/Storable.pm new file mode 100644 index 0000000..cb13c69 --- /dev/null +++ b/lib/Data/Session/Serialize/Storable.pm @@ -0,0 +1,129 @@ +package 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<Data::Session::Serialize::Storable> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +Warning: Storable should be avoided until this problem is fixed: +L<http://rt.cpan.org/Public/Bug/Display.html?id=36087> + +=head1 Description + +L<Data::Session::Serialize::Storable> allows L<Data::Session> to manipulate sessions with +L<Storable>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Serialize::Storable>. + +C<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. + +=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<Storable>. + +=head1 Method: thaw($data) + +Returns $data thawed by L<Storable>. + +=head1 Support + +Log a bug on RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/lib/Data/Session/Serialize/YAML.pm b/lib/Data/Session/Serialize/YAML.pm new file mode 100644 index 0000000..0c51e97 --- /dev/null +++ b/lib/Data/Session/Serialize/YAML.pm @@ -0,0 +1,125 @@ +package 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<Data::Session::Serialize::YAML> - A persistent session manager + +=head1 Synopsis + +See L<Data::Session> for details. + +=head1 Description + +L<Data::Session::Serialize::YAML> allows L<Data::Session> to manipulate sessions with L<YAML::Tiny>. + +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<Data::Session/Case-sensitive Options> for important information. + +=head1 Method: new() + +Creates a new object of type L<Data::Session::Serialize::YAML>. + +C<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. + +=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<YAML::Tiny>. + +=head1 Method: thaw($data) + +Returns $data thawed by L<YAML::Tiny>. + +=head1 Support + +Log a bug on RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Session>. + +=head1 Author + +L<Data::Session> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2010. + +Home page: L<http://savage.net.au/index.html>. + +=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 diff --git a/scripts/berkeleydb.pl b/scripts/berkeleydb.pl new file mode 100644 index 0000000..022167c --- /dev/null +++ b/scripts/berkeleydb.pl @@ -0,0 +1,63 @@ +#!/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; +} diff --git a/scripts/cgi.demo.cgi b/scripts/cgi.demo.cgi new file mode 100644 index 0000000..8aa32e4 --- /dev/null +++ b/scripts/cgi.demo.cgi @@ -0,0 +1,77 @@ +#!/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 <<EOS; +<html> +<head><title>$title</title></head> +<body> + Number of times this script has been run: $count.<br/> + Current value of $name: $id.<br/> + <form id='sample' method='post' name='sample'> + <button id='submit'>Click to submit</button> + <input type='hidden' name='$name' id='$name' value='$id' /> + </form> +</body> +</html> +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; diff --git a/scripts/cgi.sha1.pl b/scripts/cgi.sha1.pl new file mode 100644 index 0000000..3799885 --- /dev/null +++ b/scripts/cgi.sha1.pl @@ -0,0 +1,54 @@ +#!/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; +} diff --git a/scripts/cookie.pl b/scripts/cookie.pl new file mode 100644 index 0000000..b0073b5 --- /dev/null +++ b/scripts/cookie.pl @@ -0,0 +1,34 @@ +#!/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"; diff --git a/scripts/digest.pl b/scripts/digest.pl new file mode 100644 index 0000000..18ff79f --- /dev/null +++ b/scripts/digest.pl @@ -0,0 +1,32 @@ +#!/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"; +} diff --git a/scripts/expire.pl b/scripts/expire.pl new file mode 100644 index 0000000..1e95f96 --- /dev/null +++ b/scripts/expire.pl @@ -0,0 +1,58 @@ +#!/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); diff --git a/scripts/file.autoincrement.pl b/scripts/file.autoincrement.pl new file mode 100644 index 0000000..3d2c533 --- /dev/null +++ b/scripts/file.autoincrement.pl @@ -0,0 +1,49 @@ +#!/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; +} diff --git a/scripts/file.sha1.pl b/scripts/file.sha1.pl new file mode 100644 index 0000000..db39274 --- /dev/null +++ b/scripts/file.sha1.pl @@ -0,0 +1,48 @@ +#!/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; +} diff --git a/scripts/memcached.pl b/scripts/memcached.pl new file mode 100644 index 0000000..f1d1ec4 --- /dev/null +++ b/scripts/memcached.pl @@ -0,0 +1,50 @@ +#!/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; +} diff --git a/scripts/sqlite.pl b/scripts/sqlite.pl new file mode 100644 index 0000000..50caf33 --- /dev/null +++ b/scripts/sqlite.pl @@ -0,0 +1,61 @@ +#!/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; +} diff --git a/t/00.versions.t b/t/00.versions.t new file mode 100644 index 0000000..95f6297 --- /dev/null +++ b/t/00.versions.t @@ -0,0 +1,92 @@ +#/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; diff --git a/t/00.versions.tx b/t/00.versions.tx new file mode 100644 index 0000000..89b0e66 --- /dev/null +++ b/t/00.versions.tx @@ -0,0 +1,34 @@ +#/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; diff --git a/t/Test.pm b/t/Test.pm new file mode 100644 index 0000000..ae617d5 --- /dev/null +++ b/t/Test.pm @@ -0,0 +1,831 @@ +package 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(<<SQL, {no_sequence => 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; diff --git a/t/basic.ini b/t/basic.ini new file mode 100644 index 0000000..974d7b5 --- /dev/null +++ b/t/basic.ini @@ -0,0 +1,36 @@ +[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 diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..cf7a427 --- /dev/null +++ b/t/basic.t @@ -0,0 +1,305 @@ +#!/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); diff --git a/t/bulk.ini b/t/bulk.ini new file mode 100644 index 0000000..e8554b9 --- /dev/null +++ b/t/bulk.ini @@ -0,0 +1,36 @@ +[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 diff --git a/t/traverse.t b/t/traverse.t new file mode 100644 index 0000000..07543de --- /dev/null +++ b/t/traverse.t @@ -0,0 +1,150 @@ +#!/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); diff --git a/xt/authors/pod.t b/xt/authors/pod.t new file mode 100644 index 0000000..7a7ad3b --- /dev/null +++ b/xt/authors/pod.t @@ -0,0 +1,7 @@ +use Test::More; + +eval "use Test::Pod 1.45"; + +plan skip_all => "Test::Pod 1.45 required for testing POD" if $@; + +all_pod_files_ok(); |