view release on metacpan or  search on metacpan

t/a_cookie.t  view on Meta::CPAN

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
use diagnostics;
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..47\n"; }
END {print "not ok 1\n" unless $loaded;}

use Apache::FakeCookie;
$loaded = 1;
print "ok 1\n";
######################### End of black magic.

# Insert your test code below (better if it prints "ok 13"
# (correspondingly "not ok 13") depending on the success of chunk 13
# of the test code):

$test = 2;

*escape = \&Apache::Cookie::escape;

sub ok {
  print "ok $test\n";
  ++$test;
}

sub next_sec {
  my ($then) = @_;
  $then = time unless $then;
  my $now;
# wait for epoch
  do { select(undef,undef,undef,0.1); $now = time }
        while ( $then >= $now );  
  $now;
}
%scale = (
	m	=> 60,
	h	=> 60*60,
	d	=> 60*60*24,
	M	=> 60*60*24*30,
	y	=> 60*60*24*30*365,
);
 
# make cookie time
sub cook_time {
  my ($time) = @_;
  return undef unless $time;
  return $time if $time =~ /^[a-zA-Z]/;
  if (  $time =~ /\D/ &&
        $time =~ /([+-]?)(\d+)([mhdMy]?)/) {
    my $x = $scale{$3} || 1;
    $x = -$x if $1 && $1 eq '-';
    $time = ($2 * $x) + time;
  }
  my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  my @day = qw(Sun Mon Tue Wed Thu Fri Sat);
  my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime($time);
  return
    (qw(Sun Mon Tue Wed Thu Fri Sat))[$wday] . ', ' .                   # "%a, "
    sprintf("%02d-",$mday) .                                            # "%d " 
    (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon] . '-' . # "%b " 
    ($year + 1900) . ' ' .                                              # "%Y "
    sprintf("%02d:%02d:%02d ",$hour,$min,$sec) .                        # "%T "
    'GMT';                                                              # "%Z" 
}
# input is array of cookie values
sub fake_cookie {
  my $cookie = {@_};
  my (@vals,$val);
  if ( exists $cookie->{-value} && defined $cookie->{-value} ) {
    $val = $cookie->{-value};
    if (ref($val) eq 'HASH') {
      @vals = %$val;
    } elsif (ref($val) eq 'ARRAY') {
      @vals = @$val;
    }
  } else {
    @vals = ($val);
  }
  $cookie->{-value} = [@vals];
  return $cookie;
}

# input is pointer to cookie hash or array

sub cook2text {		# inspired by  CGI::Cookie, Lincoln D. Stein.
  my $cp = shift;
  return '' unless $cp->{-name};

  my @constant_values;

  push(@constant_values,'domain='.$cp->{-domain})
	if exists $cp->{-domain} && defined $cp->{-domain};
  push(@constant_values,'path='.$cp->{-path})
	if exists $cp->{-path} && defined $cp->{-path};
  push(@constant_values,'expires='. &cook_time($cp->{-expires}))
	if exists $cp->{-expires} && defined $cp->{-expires};
  push(@constant_values,'secure') 
	if exists $cp->{-secure} && $cp->{-secure};

  my($key) = escape($cp->{-name});