package Crypt::CGIsession;
$Crypt::CGIsession::VERSION = 2.09;
$Crypt::CGIsession::NAME    = __PACKAGE__;

=pod

   AUTHOR
      Tommy Butler <tommy @ atrixnet.com>
      phone: (817)-468-7716
      6711 Forest Park Dr
      Arlington, TX
           76001-8403

   COPYRIGHT   Tommy Butler. All rights reserved
   LISCENCE    This software is free, use/distribute under the GNU GPL.
   BUGS TO     Tommy Butler <perlmod @ atrixnet.com>

   HISTORY
         Version 1.00
         +-----------+--------------------------------------------------+
         | RELEASED: | Monday, March 4, 2002,  4:58:46 PM               |
         +-----------+--------------------------------------------------+
         | NOTES     |                                                  |
         |           | Original release of Crypt::CGIsession.pm         |
         |           |                                                  |
         | SYNOPSIS  |  Use CGI;                                        |
         |           |  Use Crypt::CGIsession;                          |
         |           |                                                  |
         |           |  my($cgi)       = CGI->new();                    |
         |           |  my($cgisess)   =                                |
         |           |     Crypt::CGIsession->new('cgi' => $cgi, );     |
         |           |                                                  |
         |           |                                                  |
         |           |  # get data from a form                          |
         |           |  my($want_newsltr) = $cgi->param('wantsnews');   |
         |           |  my($pref_format) = $cgi->param('preffmt');      |
         |           |  my($pref_pmt) = $cgi->param('prefpmt');         |
         |           |  my($name) = $cgi->param('name');                |
         |           |                                                  |
         |           |  # retrieve paramameters from the last script    |
         |           |  my($member_or_no) =                             |
         |           |     $cgisess->session_param('cust_type');        |
         |           |                                                  |
         |           |  # save form data for next script                |
         |           |  $cgisess->                                      |
         |           |     push_params                                  |
         |           |        (                                         |
         |           |           {                                      |
         |           |              'customer_type'   => $member_or_no, |
         |           |              'name'            => $name,         |
         |           |              'want_newsltr'    => $want_newsltr, |
         |           |              'prefered_fmt'    => $pref_format,  |
         |           |              'orderid'         => $order_id,     |
         |           |              'pmt_method'      => $pref_pmt,     |
         |           |           }                                      |
         |           |        );                                        |
         |           |                                                  |
         |           |  # remove un-needed params                       |
         |           |  $cgisess->                                      |
         |           |     delete_params                                |
         |           |        (                                         |
         |           |           'show flash intro',                    |
         |           |           'is new visitor',                      |
         |           |        );                                        |
         |           |                                                  |
         |           |  # a standard built-in session param             |
         |           |  my($page_last_viewed) =                         |
         |           |     $cgisess->session_param('prev');             |
         |           |                                                  |
         |           |  # another standard built-in session param       |
         |           |  my($currently_requested_page) =                 |
         |           |     $cgisess->session_param('req');              |
         |           |                                                  |
         |           |  # get the current encrypted session string      |
         |           |  my($crypted_session_string) =                   |
         |           |     $cgisess->gimme_crypted_session_string();    |
         |           |                                                  |
         |           |                                                  |
         | DEPENDENCIES                                                 |
         |           |                                                  |
         |           | This module has dependecies, namely:             |
         |           |                                                  |
         |           |    1) CGI::Util                                  |
         |           |       This module is part of the core Perl       |
         |           |       module library.  You should not need to    |
         |           |       to install it.  If you do, you can down-   |
         |           |       load it from the Comprehensive Perl        |
         |           |       Archive Network (CPAN)                     |
         |           |                                                  |
         |           |       The CPAN is located at http://www.cpan.org |
         |           |                                                  |
         |           |                                                  |
         |           |    2) Your choice of the following:              |
         |           |           Crypt::Blowfish                        |
         |           |           Crypt::Blowfish_PP                     |
         |           |           Crypt::DES                             |
         |           |           Crypt::DES_PP                          |
         |           |           Crypt::IDEA                            |
         |           |           Crypt::RSA                             |
         |           |           Crypt::TEA                             |
         |           |           Crypt::TripleDES                       |
         |           |           Crypt::Twofish                         |
         |           |                                                  |
         |           |    ...OR ANY MODULE OF THE Crypt FAMILY WHICH    |
         |           |       CAN BE USED WITH Crypt::CBC                |
         |           |                                                  |
         |           |       Any of the listed modules could change in  |
         |           |       in future versions.  This list is only     |
         |           |       intended to provide a place to start.      |
         |           |       If your Crypt module of choice can be used |
         |           |       from the Crypt::CBC interface it will work |
         |           |       for your code using Crypt::CGIsession.pm   |
         |           |                                                  |
         |           |       These modules are not part of the core     |
         |           |       Perl module library.  You will probably    |
         |           |       need to install them.  If you do, you can  |
         |           |       download them from the Comprehensive Perl  |
         |           |       Archive Network (CPAN)                     |
         |           |                                                  |
         |           |       The CPAN is located at http://www.cpan.org |
         |           |                                                  |
         |           |                                                  |
         |           |    3) Crypt::CBC                                 |
         |           |       This module is not part of the core Perl   |
         |           |       module library.  You will probably need    |
         |           |       to install it.  If you do, you can down-   |
         |           |       load it from the Comprehensive Perl        |
         |           |       Archive Network (CPAN)                     |
         |           |                                                  |
         |           |       The CPAN is located at http://www.cpan.org |
         |           |                                                  |
         |           |                                                  |
         |           |    4) expt_handler                               |
         |           |       This module is not part of the core Perl   |
         |           |       module library because it was written by   |
         |           |       me. Because of that, you'll probably need  |
         |           |       to install it.  If you do, you can down-   |
         |           |       load it from Atrixnet Open Source Perl     |
         |           |       Archives under category: /modules/         |
         |           |                                                  |
         |           |       The Atrixnet archives are located at       |
         |           |       http://www.atrixnet.com/pub/               |
         |           |                                                  |
         +-----------+--------------------------------------------------+

=cut


# use strict coding pragma
use strict;

# use encryption modules
use Crypt::CBC;

# use CGI::Util for proper query string encoding/decoding
use CGI::Util;

# use exception handler library
use expt_handler;


# --------------------------------------------------------
# Constructor
# --------------------------------------------------------
sub new {

   my($class) = shift(@_);
   my($this)  = {};
   my($name)  = __PACKAGE__;

   # -------------------------------------------
   # bless object ref into the class' namespace
   # -------------------------------------------
   bless($this, $class);


   # -------------------------------------------
   # begin setting up class attributes
   # -------------------------------------------
   my($in) = $this->coerce_array(@_);

   $this->{'session_params'}  = {};
   $this->{'name'}            = $name;
   $this->{'read_session'}    = qr/(?o)%([a-fA-F0-9]{2})/;
   $this->{'cgi'}             = $$in{'cgi'}            || {};
   $this->{'push_params'}     = $$in{'push_params'}    || {};
   $this->{'cypher_key'}      = $$in{'cypher_key'}     || '';
   $this->{'cypher'}          = $$in{'cypher'}         || 'Blowfish';
   $this->{'iv'}              = $$in{'iv'}             || '';
   $this->{'exclude-Xelems'}  = $$in{'exclude-Xelems'} || '';
   $this->{'unescape'}        = $$in{'unescape'}       || 0;
   $this->{'debug'}           = $$in{'debug'}          || 0;
   $this->{'verbose'}         = $$in{'verbose'}        || 0;
   $this->{'sessvar'}         = $$in{'sessvar'}        || 'session';

   # default session duration to 5 min
   $this->{'duration'}        = $this->to_seconds( $$in{'duration'} ) || 300;

   # local debug object
   $this->{'stack'} = expt_handler->new();

   # -------------------------------------------
   # finish by verifying class attributes
   # -------------------------------------------
   $this->verify_attributes();

   $this->init();

   # return object reference
   return($this);
}


# --------------------------------------------------------
# Crypt::CGIsession::verify_attributes()
# --------------------------------------------------------
sub verify_attributes {

   my($this)   = shift(@_);
   my($name)   = $this->{'name'};
   my($stack)  = $this->{'stack'};

   $stack->
      quit
         (
            $this->{'errors'}{'no cgi'}
         )
            if (not $this->{'cgi'});

   $stack->
      quit
         (
            $this->{'errors'}{'no iv'}
         )
            if (not $this->{'iv'}); $this->{'iv'} =
            sprintf( q[%8.8s], $this->{'iv'} );

   $stack->
      quit
         (
            $this->{'errors'}{'no cypher'}
         )
            if (not $this->{'cypher_key'});

   return(1);
}


# --------------------------------------------------------
# Crypt::CGIsession::init()
# --------------------------------------------------------
sub init {

   my($this)            = shift(@_);
   my($cgi)             = $this->{'cgi'};
   my(@uncrypted)       = ();
   my($delim)           = 0;
   my($self_ref)        = {};
   my($session_pairs)   = [];
   my($new_pair)        = [];
   my($sess_elements)   = {};
   my($element)         = '';
   my($session_qstr)    = '';
   my($sess_len)        = $this->{'duration'}||300;


  $this->read_session( $cgi->param($this->{'sessvar'}) );

   warn
      (
         qq[$this->{'name'}::init has been called]
      ) if $this->{'verbose'};


   unless ($this->{'exclude-Xelems'}) {

      $sess_elements =
         {
            'X-req'       => $cgi->script_name(),
            'X-prevreq'   => $this->session_param('X-req') || 'first request',
            'X-started'   => time(),
            'X-elapsed'   => time() - ( $this->session_param('X-started')||0 ),
            'X-expires'   => time() + $sess_len,
         };

      $$this{'session_status'} = $$sess_elements{'X-elapsed'} < $sess_len;
   }


   # we only need these values for this session...
   $this->delete_params(keys(%{$sess_elements}));

   my($uncrypted) = $cgi->param('.') || '';

   @uncrypted = split(/\:/, $uncrypted);

   foreach (@uncrypted) {

      my($name,$value) = split(/\./, $_);

      $sess_elements->{ $name } = $value;
   }


   $this->push_params($sess_elements);

   return(1);
}


# --------------------------------------------------------
# Crypt::CGIsession::to_seconds()
# --------------------------------------------------------
sub to_seconds {

   my($this)   = shift(@_);
   my($unit)   = shift(@_) || '10 minutes';
   my($amt)    = 0;

   $unit =~ s/(?go)^(?: )+|(?: )+$//;

   ($amt,$unit) = split(/ /,$unit);


   if ($unit  =~ /(?o)sec/) {

      return($amt);
   }
   elsif ($unit =~ /(?o)min/) {

      # 1 minute = 60 seconds
      return($amt * 60);
   }
   elsif ($unit =~ /(?o)hour/) {

      # 1 hour       = 60 minutes
      # 60 minutes   = 3600 seconds
      return($amt * 3600);
   }
   elsif ($unit =~ /(?o)day/) {

      # 1 day        = 24 hours
      # 24 hours     = 1440 minutes
      # 1440 minutes = 86400 seconds
      return($amt * 86400);
   }
   elsif ($unit =~ /(?o)week/) {

      # 1 week             = 7.0347222 days
      # 7.0347222 days     = 168.8333333 hours
      # 168.8333333 hours  = 10130 minutes
      # 10130 minutes      = 607800 seconds
      return($amt * 607800);
   }
   elsif ($unit =~ /(?o)year/) {

      # 1 year                   = 365.2425116 days
      # 365.2425116 days         = 8765.8202778 hours
      # 8765.8202778 hours       = 525949.2166667 minutes
      # 525949.2166667 minutes   = 31556953 seconds
      return($amt * 31556953);
   }
   elsif ($unit =~ /(?o)never/) {

      return(-2)
   }
   else { return(-1) }
}


# --------------------------------------------------------
# Crypt::CGIsession::session_status
# --------------------------------------------------------
sub session_status { $_[0]->{'session_status'}||0 }


# --------------------------------------------------------
# Crypt::CGIsession::get_session_qstr()
# --------------------------------------------------------
sub get_session_qstr {

   my($this)            = shift(@_);
   my($argstring)       = shift(@_);

   return ( $this->crypt_string($argstring) )
      if $argstring;


   $this->
      {'stack'}->
         fwarn
            (
               q[no argstring was passed to get_session_qstr()]
            )
               if
                  ($this->{'verbose'});

   return();
}


# --------------------------------------------------------
# Crypt::CGIsession::gimme_crypted_session_string()
# --------------------------------------------------------
sub gimme_crypted_session_string {

   my($this)   = shift(@_);

   return
      (
         $this->{'session'}{'crypted session args'}
      );
}


# --------------------------------------------------------
# Crypt::CGIsession::gimme_normal_session_string()
# --------------------------------------------------------
sub gimme_normal_session_string {

   my($this)   = shift(@_);

   return
      (
         $this->{'raw session string'}
      );
}


# --------------------------------------------------------
# Crypt::CGIsession::push_params()
# --------------------------------------------------------
sub push_params {

   my($this)            = shift(@_);
   my($params_2_push)   = shift  || {};
   my($session_pairs)   = [];
   my($session_qstr)    = '';
   my($i)               = 0;

   return($this->gimme_crypted_session_string())
      if
         (scalar(keys(%{$params_2_push})) == 0);

   # stick values into the session params hash
   foreach (keys(%{$params_2_push})) {

      next
         if
            (
               not defined($params_2_push->{$_})
                  ||
               length($params_2_push->{$_}) == 0
            );

      unless (length($params_2_push->{$_}) == 0) {

         unshift
            (
               @{ $this->{'session_params'}{$_} },
               $params_2_push->{$_},
            );

         ++$i;

         warn(<<__stat__) if $this->{'debug'};
$i name/value pairs pushed...       <$_> = <$params_2_push->{$_}>
__stat__

      }
   }

   return($this->gimme_crypted_session_string()) if ($i == 0);

   foreach (keys(%{ $this->{'session_params'} })) {

      my($param)  = $_;
      my($values) = $this->{'session_params'}{$_}||'';

      foreach (@{$values}) {

         next unless defined($_);
         next unless (length($_) > 0);

         push
            (
               @{ $session_pairs },
               join
                  (
                     '=',
                     ($param, $_),
                  )
            );
      }
   }

   # create next crypted session string
   $session_qstr =
      join
         (
            ';',
            @{ $session_pairs },
         );

   $this->{'raw session string'} = $session_qstr;

   my($pushed) = join(qq[\n], keys(%{ $params_2_push }));

   $this->
      {'stack'}->
         fwarn(<<__dbg__) if ($this->{'verbose'});
Session parameters have been updated. Session args which will be passed
to the next script:

$session_qstr

__dbg__

   $pushed = join(q[, ], keys(%{ $params_2_push }));

   warn(<<__dbg__) if ($this->{'debug'} and not $this->{'verbose'});
new string: $session_qstr

__dbg__

   # assign it to the proper package variable for this module
   $this->
      {'session'}
         {'crypted session args'} =

            $this->
               get_session_qstr
                  (
                     $session_qstr
                  );

   return( $this->{'session'}{'crypted session args'} );
}


# --------------------------------------------------------
# Crypt::CGIsession::clear_session()
# --------------------------------------------------------
sub clear_session {

   my($this) = shift(@_);
   $this->{'session_params'} = {};
   $this->{'session'}{'crypted session args'} = '';

   return('');
}


# --------------------------------------------------------
# Crypt::CGIsession::delete_params()
# --------------------------------------------------------
sub delete_params {

   my($this)            = shift(@_);
   my($cgi)             = $this->{'cgi'};
   my($session_pairs)   = [];
   my($session_qstr)    = '';
   my(@kill)            = @_;
   my($i)               = 0;


   foreach (@_) {

      splice(@kill,1,$i)
         if
            (not defined($_) or length($_) == 0);
      ++$i;
   }

   return($this->gimme_crypted_session_string()) if (scalar(@kill) == 0);

   foreach (@kill) {

      next unless (defined($this->{'session_params'}{$_}));

      delete($this->{'session_params'}{$_});
   }

   foreach (keys(%{ $this->{'session_params'} })) {

      my($param)  = $_;
      my($values) = $this->{'session_params'}{$_}||'';

      foreach (@{$values}) {

         next unless defined($_);
         next unless (length($_) > 0);

         push
            (
               @{ $session_pairs },
               join
                  (
                     '=',
                     ($param, $_),
                  )
            );
      }
   }

   # create next crypted session string
   $session_qstr =
      join
         (
            ';',
            @{ $session_pairs },
         );

   $this->{'raw session string'} = $session_qstr;

   my($d_leted) = join(qq[\,], @kill);

   warn(<<__dbg__) if ($this->{'debug'});

deleted: $d_leted
new string: $session_qstr

__dbg__

   # assign it to the proper package variable for this module
   $this->
      {'session'}
         {'crypted session args'} =

            $this->
               get_session_qstr
                  ( $session_qstr );

   return( $this->{'session'}{'crypted session args'} );
}


# --------------------------------------------------------
# Crypt::CGIsession::read_session()
# --------------------------------------------------------
sub read_session {

   my($this)            = shift(@_);
   my($argstring)       = shift(@_);
   my($cgi)             = $this->{'cgi'};
   my($session)         = $this->{'session'};
   my($regex_ref)       = $this->{'read_session'};
   my($decrypted)       = '';

   $decrypted  = $this->decrypt_string( $argstring ) || '';

   my(@pairs)  = split(/[;&]/, $decrypted);

   warn(<<'__babysit__') if $this->{'debug'};

Reading previous session data...
__babysit__

   { # lets' face it, Perl's warnings suck in places like this.

      my($i) = 1;
      foreach (@pairs) {

         local($^W) = 0; my($dummy) = eval('no warnings;undef($dummy);');

         # here's the killer
         my($name, $value) = split('=', $_);

         $name  = '' unless (length($name) > 0);

         $value = '' unless (length($value) > 0);

         warn(<<__babysit__) if $this->{'debug'};
$i name/value pairs read...       <$name> = <$value>
__babysit__

         ++$i;
         unshift(@{ $this->{'session_params'}{$name} }, $value)
            unless
               (length($value) == 0);
      }
   }

   warn('-'x 25,qq[\n]) if $this->{'debug'};

   $this->
      {'session'}
         {'expires'} = $this->session_param('expires');

   $this->
      {'session'}
         {'start'}   = $this->session_param('start');

   $this->
      {'session'}
         {'uid'}     = $this->session_param('uid') || 'unidentified';

   $this->{'decrypted session args'} = $decrypted;

   $this->
      {'stack'}->
         fwarn
            (
               qq[Newly decrypted session args: $decrypted]
            )
               if ($this->{'debug'} and $this->{'verbose'});

   return( $decrypted );
}


# --------------------------------------------------------
# Crypt::CGIsession::crypt_string()
# --------------------------------------------------------
sub crypt_string {

   my($this)            = shift(@_);
   my($argstring)       = shift(@_);
   my($cgi)             = $this->{'cgi'};
   my($cypher_key)      = $this->{'cypher_key'};
   my($newline)         = qq[\n];
   my($transliterate)   = 0;
   my($delim)           = 0;
   my($crypted)         = 0;

   my($cipher) =

      Crypt::CBC->
         new
            (
               {
                  'cipher'          => $this->{'cypher'},
                  'key'             => $this->{'cypher_key'},
                  'iv'              => $this->{'iv'},
                  'padding'         => 'space',
                  'regenerate_key'  => 1,
                  'prepend_iv'      => 0,
               }
            );


   $crypted = $cipher->encrypt($argstring);

   $crypted =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x", ord($1))/eg;

   return ( $crypted );
}


# --------------------------------------------------------
# Crypt::CGIsession::decrypt_string()
# --------------------------------------------------------
sub decrypt_string {

   my($this)            = shift(@_);
   my($argstring)       = shift(@_) || '';
   my($cgi)             = $this->{'cgi'};
   my($session)         = $this->{'session'};
   my($cypher_key)      = $this->{'cypher_key'};
   my($regex_ref)       = $this->{'read_session'};
   my($newline)         = qq[\n];
   my($transliterate)   = 0;
   my($delim)           = 0;
   my($decrypted)       = '';

   return(undef) if (length($argstring) == 0);

   my($cipher) =

      Crypt::CBC->
         new
            (
               {
                  'cipher'          => $this->{'cypher'},
                  'key'             => $this->{'cypher_key'},
                  'iv'              => $this->{'iv'},
                  'padding'         => 'space',
                  'regenerate_key'  => 1,
                  'prepend_iv'      => 0,
               }
            );

   if ($this->{'unescape'} || $ENV{'REQUEST_METHOD'} =~ /POST/i) {

      $argstring = CGI::Util::unescape($argstring);
   }

   $decrypted = $cipher->decrypt($argstring);

   return( $decrypted );
}


# --------------------------------------------------------
# Crypt::CGIsession::session_param()
# --------------------------------------------------------
sub session_param {

   my($this)            = shift(@_);
   my($cgi)             = $this->{'cgi'};
   my($lookup)          = shift(@_);

   return(undef)
      unless exists $this->{'session_params'};

   return($this->{'session_params'})
      unless defined $lookup;


   if (exists $this->{'session_params'}{ $lookup }) {

      return (wantarray())  ?  @{ $this->{'session_params'}{ $lookup } }
                            :  $this->{'session_params'}{ $lookup }[0];
   }

   return(undef);
};


# --------------------------------------------------------
# Crypt::CGIsession::coerce_array()
# --------------------------------------------------------
sub coerce_array {

   my($this)      = shift(@_);
   my($hashref)   = {};
   my($i)         = 0;
   my(@shadow)    = @_;

   while (@shadow) {

      my($name,$val) = splice(@shadow,0,2);

      if (defined($name)) {

         $hashref->{$name} = (defined($val)) ? $val : '';
      }
      else {

         $hashref->{qq[un-named key no. $i]} = (defined($val)) ? $val : '';
      }
   }

   return($hashref);
}


# --------------------------------------------------------
# Crypt::CGIsession::DESTROY()
# --------------------------------------------------------
sub DESTROY { } sub AUTOLOAD { }


# --------------------------------------------------------
# $Crypt::CGIsession::errors -(an anonymous HASH)
# --------------------------------------------------------
$Crypt::CGIsession::errors = {};
$Crypt::CGIsession::errors =

   {
      'no cgi'    => <<__nocgi__,

   $Crypt::CGIsession::NAME needs a reference to a CGI object. (CGI.pm)

   Refer to the documentation at the top of this module for a usage
   example where a $Crypt::CGIsession::NAME object is created and a
   CGI object reference is passed to it.

__nocgi__

      'no iv'     => <<__noiv__,

   An initialization value must be specified by passing in a key of
   'iv' as an option to Crypt::CGIsession::NAME::new() It can be
   be any series of 8 characters.

   Refer to the documentation at the top of this module for a usage
   example where a $Crypt::CGIsession::NAME object is created and an
   initialization value, or "iv" is passed to it.

__noiv__

      'no cypher' => <<__nocypher__,

   A encryption/decryption key must be specified by passing in a key of
   'cypher_key' as an option to Crypt::CGIsession::NAME::new() It can
   be any series of characters of any length.

   Refer to the documentation at the top of this module for a usage
   example where a $Crypt::CGIsession::NAME object is created and a
   encryption/decryption key, or "cypher_key" is passed to it.

__nocypher__

   };




# --------------------------------------------------------
# end Crypt::CGIsession Class, return true on import
# --------------------------------------------------------

1;