home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Cookie.pm < prev    next >
Encoding:
Perl POD Document  |  2004-02-15  |  2.6 KB  |  107 lines
  1. # 
  2. # /*
  3. #  * *********** WARNING **************
  4. #  * This file generated by My::WrapXS/2.03-dev
  5. #  * Any changes made here will be lost
  6. #  * ***********************************
  7. #  * 1. D:/Perl/site/lib/ExtUtils/XSBuilder/WrapXS.pm:38
  8. #  * 2. D:/Perl/site/lib/ExtUtils/XSBuilder/WrapXS.pm:2064
  9. #  * 3. ../../build/xsbuilder.pl:202
  10. #  * 4. Makefile.PL:19
  11. #  */
  12. # 
  13.  
  14.  
  15. package Apache::Cookie;
  16. require DynaLoader ;
  17. use strict ;
  18. use vars qw{$VERSION @ISA} ;
  19.  
  20. push @ISA, 'DynaLoader' ;
  21. $VERSION = '2.03-dev';
  22. bootstrap Apache::Cookie $VERSION ;
  23.  
  24. # XXX How do we test for the appropriate modperl version?
  25. # The modperl package isn't necessarily loaded, but Apache2
  26. # is.  Perhaps Apache2 should always include a VERSION?
  27.  
  28. if ($ENV{MOD_PERL}) {
  29.     require mod_perl;
  30.     if ($mod_perl::VERSION > 1.99) {
  31.         die __PACKAGE__ . ": httpd must load mod_apreq.so first"
  32.                if __PACKAGE__->env ne "Apache::RequestRec";
  33.     }
  34.     elsif ($mod_perl::VERSION > 1.24) {
  35.         die __PACKAGE__ . ": httpd must load mod_apreq1.so first"
  36.               if __PACKAGE__->env ne "Apache";
  37.     }
  38.     else {
  39.        die "Unrecognized mod_perl version number: $modperl::VERSION";
  40.     }
  41. }
  42.  
  43. use strict;
  44. use warnings FATAL => 'all';
  45.  
  46. use APR;
  47. use APR::Table;
  48.  
  49. package Apache::Cookie::Jar;
  50. push our(@ISA), __PACKAGE__ -> env;
  51.  
  52. package Apache::Cookie::Table;
  53. push our(@ISA), 'APR::Table';
  54.  
  55. package Apache::Cookie;
  56.  
  57. sub jar {
  58.     my $self = shift;
  59.     return Apache::Cookie::Jar->new(@_);
  60. }
  61.  
  62. sub new {
  63.     my ($class, $env, %attrs) = @_;
  64.     my $name  = delete $attrs{name};
  65.     my $value = delete $attrs{value};
  66.     $name     = delete $attrs{-name}  unless defined $name;
  67.     $value    = delete $attrs{-value} unless defined $value;
  68.     return unless defined $name and defined $value;
  69.  
  70.     my $cookie = $class->make($env, $name, $class->freeze($value));
  71.     $cookie->set_attr(%attrs);
  72.     return $cookie;
  73. }
  74.  
  75. sub fetch {
  76.     my $self = shift;
  77.     my $jar = $self->jar(@_);
  78.     return wantarray ? %{scalar $jar->cookie} : $jar->cookie;
  79. }
  80.  
  81. sub freeze {
  82.     my ($class, $value) = @_;
  83.     return encode($value) if not ref $value;
  84.     return $value->freeze if UNIVERSAL::can($value,"freeze");
  85.     if (UNIVERSAL::isa($value,"ARRAY")) {
  86.         return join '&', map encode($_), @$value;
  87.     }
  88.     elsif (UNIVERSAL::isa($value,"HASH")) {
  89.         return join '&', map encode($_), %$value;
  90.     }
  91.     else {
  92.         die "Can't freeze '$value'";
  93.     }
  94. }
  95.  
  96. sub thaw {
  97.     my $self = shift;
  98.     my @rv = map decode($_), split /&/, $self->raw_value;
  99.     return wantarray ? @rv : $rv[0];
  100. }
  101.  
  102. sub value { shift->thaw }
  103.  
  104.  
  105. 1;
  106. __END__
  107.