Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

doesn't provide hash slices

  • Loading branch information...
commit 2343ffb2fa5c895a8bf89a56634155ffcd41f802 1 parent e64f8ef
Ryo Anazawa authored
433 lib/CGI/Header.pm
@@ -2,67 +2,235 @@ package CGI::Header;
2 2 use 5.008_009;
3 3 use strict;
4 4 use warnings;
5   -use overload '%{}' => 'as_hashref', q{""} => 'as_string', fallback => 1;
6   -use parent 'CGI::Header::Entity';
  5 +use overload q{""} => 'as_string', fallback => 1;
7 6 use Carp qw/carp croak/;
8 7 use Scalar::Util qw/refaddr/;
  8 +use List::Util qw/first/;
9 9
10 10 our $VERSION = '0.01';
11 11
12 12 my %header_of;
13 13
14 14 sub new {
15   - my $class = shift;
  15 + my $class = shift;
16 16 my $header = ref $_[0] eq 'HASH' ? shift : { @_ };
17   - $class->SUPER::new( $header );
  17 + my $self = bless \do { my $anon_scalar }, $class;
  18 + my $this = refaddr $self;
  19 +
  20 + $header_of{ $this } = $header;
  21 +
  22 + $self;
18 23 }
19 24
20 25 sub get {
21   - my ( $self, @fields ) = @_;
22   - my @values = map { $self->FETCH($_) } @fields;
23   - wantarray ? @values : $values[-1];
  26 + my $self = shift;
  27 + my $norm = $self->_normalize( shift );
  28 + my $this = refaddr $self;
  29 + my $header = $header_of{ $this };
  30 +
  31 + if ( $norm eq '-content_type' ) {
  32 + my $type = $header->{-type};
  33 + my $charset = $header->{-charset};
  34 +
  35 + if ( defined $type and $type eq q{} ) {
  36 + undef $charset;
  37 + undef $type;
  38 + }
  39 + else {
  40 + $type ||= 'text/html';
  41 +
  42 + if ( $type =~ /\bcharset\b/ ) {
  43 + undef $charset;
  44 + }
  45 + elsif ( !defined $charset ) {
  46 + $charset = 'ISO-8859-1';
  47 + }
  48 + }
  49 +
  50 + return $charset ? "$type; charset=$charset" : $type;
  51 + }
  52 + elsif ( $norm eq '-content_disposition' ) {
  53 + if ( my $filename = $header->{-attachment} ) {
  54 + return qq{attachment; filename="$filename"};
  55 + }
  56 + }
  57 + elsif ( $norm eq '-date' ) {
  58 + if ( $self->_date_header_is_fixed ) {
  59 + require HTTP::Date;
  60 + return HTTP::Date::time2str( time );
  61 + }
  62 + }
  63 + elsif ( $norm eq '-expires' ) {
  64 + if ( my $expires = $header->{-expires} ) {
  65 + require CGI::Util;
  66 + return CGI::Util::expires( $expires );
  67 + }
  68 + }
  69 + elsif ( $norm eq '-p3p' ) {
  70 + if ( my $p3p = $header->{-p3p} ) {
  71 + my $tags = ref $p3p eq 'ARRAY' ? join ' ', @{ $p3p } : $p3p;
  72 + return qq{policyref="/w3c/p3p.xml", CP="$tags"};
  73 + }
  74 + }
  75 +
  76 + $header->{ $norm };
24 77 }
25 78
26 79 sub set {
27   - my ( $self, @headers ) = @_;
28   -
29   - if ( @headers % 2 == 0 ) {
30   - while ( my ($field, $value) = splice @headers, 0, 2 ) {
31   - $self->STORE( $field => $value );
  80 + my $self = shift;
  81 + my $norm = $self->_normalize( shift );
  82 + my $value = shift;
  83 + my $this = refaddr $self;
  84 + my $header = $header_of{ $this };
  85 +
  86 + if ( $norm eq '-date' ) {
  87 + if ( $self->_date_header_is_fixed ) {
  88 + return carp 'The Date header is fixed';
32 89 }
33 90 }
34   - else {
35   - croak 'Odd number of elements passed to set()';
  91 + elsif ( $norm eq '-content_type' ) {
  92 + $header->{-type} = $value;
  93 + $header->{-charset} = q{};
  94 + delete $header->{ $norm };
  95 + return;
  96 + }
  97 + elsif ( $norm eq '-content_disposition' ) {
  98 + delete $header->{-attachment};
  99 + }
  100 + elsif ( $norm eq '-cookie' ) {
  101 + delete $header->{-date};
  102 + }
  103 + elsif ( $norm eq '-p3p' or $norm eq '-expires' ) {
  104 + carp "Can't assign to '$norm' directly, use accessors instead";
  105 + return;
36 106 }
37 107
  108 + $header->{ $norm } = $value;
  109 +
38 110 return;
39 111 }
40 112
41 113 sub delete {
42   - my ( $self, @fields ) = @_;
  114 + my $self = shift;
  115 + my $field = shift;
  116 + my $norm = $self->_normalize( $field );
  117 + my $value = defined wantarray && $self->get( $field );
  118 + my $this = refaddr $self;
  119 + my $header = $header_of{ $this };
  120 +
  121 + if ( $norm eq '-date' ) {
  122 + if ( $self->_date_header_is_fixed ) {
  123 + return carp 'The Date header is fixed';
  124 + }
  125 + }
  126 + elsif ( $norm eq '-content_type' ) {
  127 + delete $header->{-charset};
  128 + $header->{-type} = q{};
  129 + }
  130 + elsif ( $norm eq '-content_disposition' ) {
  131 + delete $header->{-attachment};
  132 + }
  133 +
  134 + delete $header->{ $norm };
  135 +
  136 + $value;
  137 +}
  138 +
  139 +sub clear {
  140 + my $self = shift;
  141 + my $this = refaddr $self;
  142 + %{ $header_of{$this} } = ( -type => q{} );
  143 + return;
  144 +}
  145 +
  146 +sub exists {
  147 + my $self = shift;
  148 + my $norm = $self->_normalize( shift );
  149 + my $this = refaddr $self;
  150 + my $header = $header_of{ $this };
43 151
44   - if ( wantarray ) {
45   - return map { $self->DELETE($_) } @fields;
  152 + if ( $norm eq '-content_type' ) {
  153 + return !defined $header->{-type} || $header->{-type} ne q{};
46 154 }
47   - elsif ( defined wantarray ) {
48   - my $deleted = @fields && $self->DELETE( pop @fields );
49   - $self->DELETE( $_ ) for @fields;
50   - return $deleted;
  155 + elsif ( $norm eq '-content_disposition' ) {
  156 + return 1 if $header->{-attachment};
51 157 }
52   - else {
53   - $self->DELETE( $_ ) for @fields;
  158 + elsif ( $norm eq '-date' ) {
  159 + return 1 if first { $header->{$_} } qw(-nph -expires -cookie);
54 160 }
55 161
  162 + $header->{ $norm };
  163 +}
  164 +
  165 +sub DESTROY {
  166 + my $self = shift;
  167 + my $this = refaddr $self;
  168 + delete $header_of{ $this };
56 169 return;
57 170 }
58 171
59   -sub clear { shift->CLEAR }
60   -sub exists { shift->EXISTS( @_ ) }
61   -sub is_empty { not shift->SCALAR }
  172 +sub header {
  173 + my $self = shift;
  174 + my $this = refaddr $self;
  175 + $header_of{ $this };
  176 +}
  177 +
  178 +BEGIN {
  179 + *TIEHASH = \&new;
  180 + *STORE = \&set;
  181 + *FETCH = \&get;
  182 + *CLEAR = \&clear;
  183 + *EXISTS = \&exists;
  184 + *DELETE = \&delete;
  185 +}
  186 +
  187 +sub SCALAR {
  188 + my $self = shift;
  189 + my $this = refaddr $self;
  190 + my $header = $header_of{ $this };
  191 + !defined $header->{-type} || first { $_ } values %{ $header };
  192 +}
  193 +
  194 +sub is_empty { not shift->SCALAR }
  195 +
  196 +BEGIN {
  197 + require Storable;
  198 + *clone = \&Storable::dclone;
  199 +}
  200 +
  201 +sub field_names {
  202 + my $self = shift;
  203 + my $this = refaddr $self;
  204 + my %header = %{ $header_of{$this} }; # copy
  205 +
  206 + my @fields;
  207 +
  208 + push @fields, 'Status' if delete $header{-status};
  209 + push @fields, 'Window-Target' if delete $header{-target};
  210 + push @fields, 'P3P' if delete $header{-p3p};
  211 +
  212 + push @fields, 'Set-Cookie' if my $cookie = delete $header{-cookie};
  213 + push @fields, 'Expires' if my $expires = delete $header{-expires};
  214 + push @fields, 'Date' if delete $header{-nph} or $cookie or $expires;
  215 +
  216 + push @fields, 'Content-Disposition' if delete $header{-attachment};
  217 +
  218 + my $type = delete @header{ '-charset', '-type' };
  219 +
  220 + # not ordered
  221 + while ( my ($norm, $value) = each %header ) {
  222 + next unless $value;
  223 + push @fields, $self->_denormalize( $norm );
  224 + }
  225 +
  226 + push @fields, 'Content-Type' if !defined $type or $type ne q{};
  227 +
  228 + @fields;
  229 +}
62 230
63 231 sub flatten {
64 232 my $self = shift;
65   - map { $_, $self->FETCH($_) } $self->field_names;
  233 + map { $_, $self->get($_) } $self->field_names;
66 234 }
67 235
68 236 sub each {
@@ -70,7 +238,7 @@ sub each {
70 238
71 239 if ( ref $callback eq 'CODE' ) {
72 240 for my $field ( $self->field_names ) {
73   - $callback->( $field, $self->FETCH($field) );
  241 + $callback->( $field, $self->get($field) );
74 242 }
75 243 }
76 244 else {
@@ -80,25 +248,129 @@ sub each {
80 248 return;
81 249 }
82 250
83   -sub as_hashref {
  251 +sub attachment {
  252 + my $self = shift;
  253 + my $this = refaddr $self;
  254 + my $header = $header_of{ $this };
  255 +
  256 + if ( @_ ) {
  257 + my $filename = shift;
  258 + delete $header->{-content_disposition};
  259 + $header->{-attachment} = $filename;
  260 + return;
  261 + }
  262 +
  263 + $header->{-attachment};
  264 +}
  265 +
  266 +sub expires {
  267 + my $self = shift;
  268 + my $this = refaddr $self;
  269 + my $header = $header_of{ $this };
  270 +
  271 + if ( @_ ) {
  272 + my $expires = shift;
  273 + delete $header->{-date}; # if $expires;
  274 + $header->{-expires} = $expires;
  275 + return;
  276 + }
  277 +
  278 + $header->{-expires};
  279 +}
  280 +
  281 +sub nph {
  282 + my $self = shift;
  283 + my $this = refaddr $self;
  284 + my $header = $header_of{ $this };
  285 +
  286 + if ( @_ ) {
  287 + my $nph = shift;
  288 + delete $header->{-date} if $nph;
  289 + $header->{-nph} = $nph;
  290 + return;
  291 + }
  292 +
  293 + $header->{-nph};
  294 +}
  295 +
  296 +sub p3p_tags {
  297 + my $self = shift;
  298 + my $this = refaddr $self;
  299 + my $header = $header_of{ $this };
  300 +
  301 + if ( @_ ) {
  302 + $header->{-p3p} = @_ > 1 ? [ @_ ] : shift;
  303 + }
  304 + elsif ( my $tags = $header->{-p3p} ) {
  305 + my @tags = ref $tags eq 'ARRAY' ? @{ $tags } : split ' ', $tags;
  306 + return wantarray ? @tags : $tags[0];
  307 + }
  308 +
  309 + return;
  310 +}
  311 +
  312 +sub target {
84 313 my $self = shift;
85 314 my $this = refaddr $self;
  315 + my $header = $header_of{ $this };
  316 + $header->{-target} = shift if @_;
  317 + $header->{-target};
  318 +}
86 319
87   - unless ( exists $header_of{$this} ) {
88   - tie my %header => 'CGI::Header::Entity' => $self->header;
89   - $header_of{ $this } = \%header;
  320 +sub get_cookie {
  321 + my $self = shift;
  322 + my $name = shift;
  323 + my $this = refaddr $self;
  324 + my $header = $header_of{ $this };
  325 +
  326 + my @cookies = do {
  327 + my $cookies = $header->{-cookie};
  328 + return unless $cookies;
  329 + ref $cookies eq 'ARRAY' ? @{ $cookies } : $cookies;
  330 + };
  331 +
  332 + my @values;
  333 + for my $cookie ( @cookies ) {
  334 + next unless ref $cookie eq 'CGI::Cookie';
  335 + next unless $cookie->name eq $name;
  336 + push @values, $cookie;
90 337 }
91 338
92   - $header_of{ $this };
  339 + wantarray ? @values : $values[0];
  340 +}
  341 +
  342 +sub dump {
  343 + my $self = shift;
  344 + my $this = refaddr $self;
  345 +
  346 + require Data::Dumper;
  347 +
  348 + local $Data::Dumper::Indent = 1;
  349 +
  350 + my %dump = (
  351 + __PACKAGE__, {
  352 + header => $header_of{ $this },
  353 + },
  354 + @_,
  355 + );
  356 +
  357 + Data::Dumper::Dumper( \%dump );
  358 +}
  359 +
  360 +sub _date_header_is_fixed {
  361 + my $self = shift;
  362 + my $this = refaddr $self;
  363 + my $header = $header_of{ $this };
  364 + $header->{-expires} || $header->{-cookie} || $header->{-nph};
93 365 }
94 366
95 367 sub content_type {
96 368 my $self = shift;
97 369
98   - return $self->STORE( 'Content-Type' => shift ) if @_;
  370 + return $self->set( 'Content-Type' => shift ) if @_;
99 371
100 372 my ( $media_type, $rest ) = do {
101   - my $content_type = $self->FETCH( 'Content-Type' );
  373 + my $content_type = $self->get( 'Content-Type' );
102 374 return q{} unless defined $content_type;
103 375 split /;\s*/, $content_type, 2;
104 376 };
@@ -115,9 +387,9 @@ sub date {
115 387 require HTTP::Date;
116 388
117 389 if ( defined $time ) {
118   - $self->STORE( Date => HTTP::Date::time2str($time) );
  390 + $self->set( Date => HTTP::Date::time2str($time) );
119 391 }
120   - elsif ( my $date = $self->FETCH('Date') ) {
  392 + elsif ( my $date = $self->get('Date') ) {
121 393 return HTTP::Date::str2time( $date );
122 394 }
123 395
@@ -135,13 +407,13 @@ sub set_cookie {
135 407 \%args;
136 408 });
137 409
138   - my $cookies = $self->FETCH( 'Set-Cookie' );
  410 + my $cookies = $self->get( 'Set-Cookie' );
139 411
140 412 if ( !$cookies ) {
141   - return $self->STORE( 'Set-Cookie' => [ $new_cookie ] );
  413 + return $self->set( 'Set-Cookie' => [ $new_cookie ] );
142 414 }
143 415 elsif ( ref $cookies ne 'ARRAY' ) {
144   - $self->STORE( 'Set-Cookie' => $cookies = [ $cookies ] );
  416 + $self->set( 'Set-Cookie' => $cookies = [ $cookies ] );
145 417 }
146 418
147 419 my $set;
@@ -159,36 +431,40 @@ sub set_cookie {
159 431 }
160 432
161 433 sub status {
162   - my $self = shift;
  434 + my $self = shift;
  435 + my $this = refaddr $self;
  436 + my $header = $header_of{ $this };
163 437
164 438 require HTTP::Status;
165 439
166 440 if ( @_ ) {
167 441 my $code = shift;
168 442 my $message = HTTP::Status::status_message( $code );
169   - return $self->STORE( Status => "$code $message" ) if $message;
  443 + return $header->{-status} = "$code $message" if $message;
170 444 carp "Unknown status code '$code' passed to status()";
171 445 }
172   - elsif ( my $status = $self->FETCH('Status') ) {
  446 + elsif ( my $status = $header->{-status} ) {
173 447 return substr( $status, 0, 3 );
174 448 }
175 449 else {
176   - return 200;
  450 + return '200';
177 451 }
178 452
179 453 return;
180 454 }
181 455
182 456 sub as_string {
183   - my $self = shift;
184   - my $eol = defined $_[0] ? shift : "\n";
  457 + my $self = shift;
  458 + my $eol = defined $_[0] ? shift : "\n";
  459 + my $this = refaddr $self;
  460 + my $header = $header_of{ $this };
185 461
186 462 my @lines;
187 463
188   - if ( $self->nph ) {
189   - my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
190   - my $software = $ENV{SERVER_SOFTWARE} || 'cmdline';
191   - my $status = $self->FETCH('Status') || '200 OK';
  464 + if ( $header->{-nph} ) {
  465 + my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
  466 + my $software = $ENV{SERVER_SOFTWARE} || 'cmdline';
  467 + my $status = $header->{-status} || '200 OK';
192 468 push @lines, "$protocol $status";
193 469 push @lines, "Server: $software";
194 470 }
@@ -211,22 +487,53 @@ sub as_string {
211 487 join $eol, @lines, q{};
212 488 }
213 489
214   -sub dump {
215   - my $self = shift;
216   - my $package = __PACKAGE__;
  490 +sub STORABLE_freeze {
  491 + my ( $self, $cloning ) = @_;
  492 + ( q{}, $header_of{ refaddr $self } );
  493 +}
217 494
218   - $self->SUPER::dump(
219   - $package => {
220   - header => { $self->flatten },
221   - },
222   - @_,
223   - );
  495 +sub STORABLE_thaw {
  496 + my ( $self, $serialized, $cloning, $header ) = @_;
  497 + $header_of{ refaddr $self } = $header;
  498 + $self;
224 499 }
225 500
226   -sub DESTROY {
227   - my $self = shift;
228   - delete $header_of{ refaddr $self };
229   - $self->SUPER::DESTROY;
  501 +my %norm_of = (
  502 + -attachment => q{}, -charset => q{},
  503 + -cookie => q{}, -nph => q{},
  504 + -set_cookie => q{-cookie}, -target => q{},
  505 + -type => q{}, -window_target => q{-target},
  506 +);
  507 +
  508 +sub _normalize {
  509 + my $class = shift;
  510 + my $field = lc shift;
  511 +
  512 + # transliterate dashes into underscores
  513 + $field =~ tr{-}{_};
  514 +
  515 + # add an initial dash
  516 + $field = "-$field";
  517 +
  518 + exists $norm_of{$field} ? $norm_of{ $field } : $field;
  519 +}
  520 +
  521 +my %field_name_of = (
  522 + -attachment => 'Content-Disposition', -cookie => 'Set-Cookie',
  523 + -p3p => 'P3P', -target => 'Window-Target',
  524 + -type => 'Content-Type',
  525 +);
  526 +
  527 +sub _denormalize {
  528 + my ( $class, $norm ) = @_;
  529 +
  530 + unless ( exists $field_name_of{$norm} ) {
  531 + ( my $field = $norm ) =~ s/^-//;
  532 + $field =~ tr/_/-/;
  533 + $field_name_of{ $norm } = ucfirst $field;
  534 + }
  535 +
  536 + $field_name_of{ $norm };
230 537 }
231 538
232 539 1;
375 lib/CGI/Header/Entity.pm
... ... @@ -1,375 +0,0 @@
1   -package CGI::Header::Entity;
2   -use strict;
3   -use warnings;
4   -use Carp qw/carp croak/;
5   -use List::Util qw/first/;
6   -use Scalar::Util qw/refaddr/;
7   -
8   -my %header_of;
9   -
10   -sub TIEHASH {
11   - my $class = shift;
12   - my $header = ref $_[0] eq 'HASH' ? shift : {};
13   - my $self = bless \do { my $anon_scalar }, $class;
14   - $header_of{ refaddr $self } = $header;
15   - $self;
16   -}
17   -
18   -BEGIN { *new = \&TIEHASH }
19   -
20   -sub FETCH {
21   - my $self = shift;
22   - my $norm = $self->_normalize( shift );
23   - my $header = $header_of{ refaddr $self };
24   -
25   - if ( $norm eq '-content_type' ) {
26   - my $type = $header->{-type};
27   - my $charset = $header->{-charset};
28   -
29   - if ( defined $type and $type eq q{} ) {
30   - undef $charset;
31   - undef $type;
32   - }
33   - else {
34   - $type ||= 'text/html';
35   -
36   - if ( $type =~ /\bcharset\b/ ) {
37   - undef $charset;
38   - }
39   - elsif ( !defined $charset ) {
40   - $charset = 'ISO-8859-1';
41   - }
42   - }
43   -
44   - return $charset ? "$type; charset=$charset" : $type;
45   - }
46   - elsif ( $norm eq '-content_disposition' ) {
47   - if ( my $filename = $header->{-attachment} ) {
48   - return qq{attachment; filename="$filename"};
49   - }
50   - }
51   - elsif ( $norm eq '-date' ) {
52   - if ( $self->_date_header_is_fixed ) {
53   - require HTTP::Date;
54   - return HTTP::Date::time2str( time );
55   - }
56   - }
57   - elsif ( $norm eq '-expires' ) {
58   - if ( my $expires = $header->{-expires} ) {
59   - require CGI::Util;
60   - return CGI::Util::expires( $expires );
61   - }
62   - }
63   - elsif ( $norm eq '-p3p' ) {
64   - if ( my $p3p = $header->{-p3p} ) {
65   - my $tags = ref $p3p eq 'ARRAY' ? join ' ', @{ $p3p } : $p3p;
66   - return qq{policyref="/w3c/p3p.xml", CP="$tags"};
67   - }
68   - }
69   -
70   - $header->{ $norm };
71   -}
72   -
73   -sub STORE {
74   - my $self = shift;
75   - my $norm = $self->_normalize( shift );
76   - my $value = shift;
77   - my $header = $header_of{ refaddr $self };
78   -
79   - if ( $norm eq '-date' ) {
80   - if ( $self->_date_header_is_fixed ) {
81   - return carp 'The Date header is fixed';
82   - }
83   - }
84   - elsif ( $norm eq '-content_type' ) {
85   - $header->{-charset} = q{};
86   - $header->{-type} = $value;
87   - return;
88   - }
89   - elsif ( $norm eq '-content_disposition' ) {
90   - delete $header->{-attachment};
91   - }
92   - elsif ( $norm eq '-cookie' ) {
93   - delete $header->{-date};
94   - }
95   - elsif ( $norm eq '-p3p' or $norm eq '-expires' ) {
96   - carp "Can't assign to '$norm' directly, use accessors instead";
97   - return;
98   - }
99   -
100   - $header->{ $norm } = $value;
101   -
102   - return;
103   -}
104   -
105   -sub DELETE {
106   - my $self = shift;
107   - my $field = shift;
108   - my $norm = $self->_normalize( $field );
109   - my $deleted = defined wantarray && $self->FETCH( $field );
110   - my $header = $header_of{ refaddr $self };
111   -
112   - if ( $norm eq '-date' ) {
113   - if ( $self->_date_header_is_fixed ) {
114   - return carp 'The Date header is fixed';
115   - }
116   - }
117   - elsif ( $norm eq '-content_type' ) {
118   - delete $header->{-charset};
119   - $header->{-type} = q{};
120   - }
121   - elsif ( $norm eq '-content_disposition' ) {
122   - delete $header->{-attachment};
123   - }
124   -
125   - delete $header->{ $norm };
126   -
127   - $deleted;
128   -}
129   -
130   -sub CLEAR {
131   - my $self = shift;
132   - my $this = refaddr $self;
133   - %{ $header_of{$this} } = ( -type => q{} );
134   - return;
135   -}
136   -
137   -sub EXISTS {
138   - my $self = shift;
139   - my $norm = $self->_normalize( shift );
140   - my $header = $header_of{ refaddr $self };
141   -
142   - if ( $norm eq '-content_type' ) {
143   - return !defined $header->{-type} || $header->{-type} ne q{};
144   - }
145   - elsif ( $norm eq '-content_disposition' ) {
146   - return 1 if $header->{-attachment};
147   - }
148   - elsif ( $norm eq '-date' ) {
149   - return 1 if first { $header->{$_} } qw(-nph -expires -cookie);
150   - }
151   -
152   - $header->{ $norm };
153   -}
154   -
155   -sub SCALAR {
156   - my $self = shift;
157   - my $header = $header_of{ refaddr $self };
158   - !defined $header->{-type} || first { $_ } values %{ $header };
159   -}
160   -
161   -sub DESTROY {
162   - my $self = shift;
163   - delete $header_of{ refaddr $self };
164   - return;
165   -}
166   -
167   -sub header { $header_of{ refaddr shift } }
168   -
169   -BEGIN {
170   - require Storable;
171   - *clone = \&Storable::dclone;
172   -}
173   -
174   -sub field_names {
175   - my $self = shift;
176   - my $this = refaddr $self;
177   - my %header = %{ $header_of{$this} }; # copy
178   -
179   - my @fields;
180   -
181   - push @fields, 'Status' if delete $header{-status};
182   - push @fields, 'Window-Target' if delete $header{-target};
183   - push @fields, 'P3P' if delete $header{-p3p};
184   -
185   - push @fields, 'Set-Cookie' if my $cookie = delete $header{-cookie};
186   - push @fields, 'Expires' if my $expires = delete $header{-expires};
187   - push @fields, 'Date' if delete $header{-nph} or $cookie or $expires;
188   -
189   - push @fields, 'Content-Disposition' if delete $header{-attachment};
190   -
191   - my $type = delete @header{ '-charset', '-type' };
192   -
193   - # not ordered
194   - while ( my ($norm, $value) = each %header ) {
195   - push @fields, $self->_denormalize( $norm ) if $value;
196   - }
197   -
198   - push @fields, 'Content-Type' if !defined $type or $type ne q{};
199   -
200   - @fields;
201   -}
202   -
203   -sub attachment {
204   - my $self = shift;
205   - my $this = refaddr $self;
206   - my $header = $header_of{ $this };
207   -
208   - if ( @_ ) {
209   - my $filename = shift;
210   - delete $header->{-content_disposition};
211   - $header->{-attachment} = $filename;
212   - }
213   - else {
214   - return $header->{-attachment};
215   - }
216   -
217   - return;
218   -}
219   -
220   -sub expires {
221   - my $self = shift;
222   - my $this = refaddr $self;
223   - my $header = $header_of{ $this };
224   -
225   - if ( @_ ) {
226   - my $expires = shift;
227   - delete $header->{-date};
228   - $header->{-expires} = $expires;
229   - }
230   - elsif ( my $expires = $self->FETCH('Expires') ) {
231   - require HTTP::Date;
232   - return HTTP::Date::str2time( $expires );
233   - }
234   -
235   - return;
236   -}
237   -
238   -sub nph {
239   - my $self = shift;
240   - my $this = refaddr $self;
241   - my $header = $header_of{ $this };
242   -
243   - if ( @_ ) {
244   - my $nph = shift;
245   - delete $header->{-date} if $nph;
246   - $header->{-nph} = $nph;
247   - }
248   - else {
249   - return $header->{-nph};
250   - }
251   -
252   - return;
253   -}
254   -
255   -sub p3p_tags {
256   - my $self = shift;
257   - my $this = refaddr $self;
258   - my $header = $header_of{ $this };
259   -
260   - if ( @_ ) {
261   - $header->{-p3p} = @_ > 1 ? [ @_ ] : shift;
262   - }
263   - elsif ( my $tags = $header->{-p3p} ) {
264   - my @tags = ref $tags eq 'ARRAY' ? @{ $tags } : split ' ', $tags;
265   - return wantarray ? @tags : $tags[0];
266   - }
267   -
268   - return;
269   -}
270   -
271   -sub target {
272   - my $self = shift;
273   - my $this = refaddr $self;
274   - my $header = $header_of{ $this };
275   - $header->{-target} = shift if @_;
276   - $header->{-target};
277   -}
278   -
279   -sub get_cookie {
280   - my $self = shift;
281   - my $name = shift;
282   - my $this = refaddr $self;
283   - my $header = $header_of{ $this };
284   -
285   - my @cookies = do {
286   - my $cookies = $header->{-cookie};
287   - return unless $cookies;
288   - ref $cookies eq 'ARRAY' ? @{ $cookies } : $cookies;
289   - };
290   -
291   - my @values;
292   - for my $cookie ( @cookies ) {
293   - next unless ref $cookie eq 'CGI::Cookie';
294   - next unless $cookie->name eq $name;
295   - push @values, $cookie;
296   - }
297   -
298   - wantarray ? @values : $values[0];
299   -}
300   -
301   -sub dump {
302   - my $self = shift;
303   - my $this = refaddr $self;
304   - my $package = __PACKAGE__;
305   -
306   - require Data::Dumper;
307   -
308   - local $Data::Dumper::Indent = 1;
309   -
310   - my %dump = (
311   - $package => {
312   - header => $header_of{ $this },
313   - },
314   - @_,
315   - );
316   -
317   - Data::Dumper::Dumper( \%dump );
318   -}
319   -
320   -sub _date_header_is_fixed {
321   - my $self = shift;
322   - my $header = $header_of{ refaddr $self };
323   - $header->{-expires} || $header->{-cookie} || $header->{-nph};
324   -}
325   -
326   -sub STORABLE_freeze {
327   - my ( $self, $cloning ) = @_;
328   - ( q{}, $header_of{ refaddr $self } );
329   -}
330   -
331   -sub STORABLE_thaw {
332   - my ( $self, $serialized, $cloning, $header ) = @_;
333   - $header_of{ refaddr $self } = $header;
334   - $self;
335   -}
336   -
337   -my %norm_of = (
338   - -attachment => q{}, -charset => q{},
339   - -cookie => q{}, -nph => q{},
340   - -set_cookie => q{-cookie}, -target => q{},
341   - -type => q{}, -window_target => q{-target},
342   -);
343   -
344   -sub _normalize {
345   - my $class = shift;
346   - my $field = lc shift;
347   -
348   - # transliterate dashes into underscores
349   - $field =~ tr{-}{_};
350   -
351   - # add an initial dash
352   - $field = "-$field";
353   -
354   - exists $norm_of{$field} ? $norm_of{ $field } : $field;
355   -}
356   -
357   -my %field_name_of = (
358   - -attachment => 'Content-Disposition', -cookie => 'Set-Cookie',
359   - -p3p => 'P3P', -target => 'Window-Target',
360   - -type => 'Content-Type',
361   -);
362   -
363   -sub _denormalize {
364   - my ( $class, $norm ) = @_;
365   -
366   - unless ( exists $field_name_of{$norm} ) {
367   - ( my $field = $norm ) =~ s/^-//;
368   - $field =~ tr/_/-/;
369   - $field_name_of{ $norm } = ucfirst $field;
370   - }
371   -
372   - $field_name_of{ $norm };
373   -}
374   -
375   -1;
4 t/00_compile.t
... ... @@ -1,7 +1,7 @@
1 1 use strict;
2   -use Test::More tests => 2;
  2 +use Test::More tests => 1;
3 3
4 4 BEGIN {
5   - use_ok 'CGI::Header::Entity';
  5 + #use_ok 'CGI::Header::Entity';
6 6 use_ok 'CGI::Header';
7 7 }
4 t/10_normalization.t
... ... @@ -1,11 +1,11 @@
1 1 use strict;
2 2 use warnings;
3   -use CGI::Header::Entity;
  3 +use CGI::Header;
4 4 use Test::Base;
5 5
6 6 plan tests => 1 * blocks();
7 7
8   -my $header = 'CGI::Header::Entity';
  8 +my $header = 'CGI::Header';
9 9
10 10 run {
11 11 my $block = shift;
4 t/11_denormalization.t
... ... @@ -1,10 +1,10 @@
1 1 use strict;
2   -use CGI::Header::Entity;
  2 +use CGI::Header;
3 3 use Test::Base;
4 4
5 5 plan tests => 1 * blocks();
6 6
7   -my $header = 'CGI::Header::Entity';
  7 +my $header = 'CGI::Header';
8 8
9 9 run {
10 10 my $block = shift;
4 t/12_entity.t
... ... @@ -1,9 +1,9 @@
1 1 use strict;
2 2 use warnings;
3   -use CGI::Header::Entity;
  3 +use CGI::Header;
4 4 use Test::More tests => 16;
5 5
6   -my $class = 'CGI::Header::Entity';
  6 +my $class = 'CGI::Header';
7 7
8 8 can_ok $class, qw(
9 9 TIEHASH FETCH STORE DELETE EXISTS CLEAR SCALAR DESTROY
4 t/13_content_type.t
... ... @@ -1,10 +1,10 @@
1 1 use strict;
2 2 use warnings;
3   -use CGI::Header::Entity;
  3 +use CGI::Header;
4 4 use Test::More tests => 28;
5 5
6 6 my %adaptee;
7   -my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
  7 +my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
8 8
9 9 %adaptee = ( -type => q{} );
10 10 is $adapter{Content_Type}, undef;
4 t/14_date.t
... ... @@ -1,12 +1,12 @@
1 1 use strict;
2 2 use warnings;
3   -use CGI::Header::Entity;
  3 +use CGI::Header;
4 4 use HTTP::Date;
5 5 use Test::More tests => 11;
6 6 use Test::Warn;
7 7
8 8 my %adaptee;
9   -my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
  9 +my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
10 10
11 11 %adaptee = ( -nph => 1 );
12 12 is $adapter{Date}, time2str( time );
4 t/15_p3p.t
... ... @@ -1,11 +1,11 @@
1 1 use strict;
2 2 use warnings;
3   -use CGI::Header::Entity;
  3 +use CGI::Header;
4 4 use Test::More tests => 11;
5 5 use Test::Warn;
6 6
7 7 my %adaptee;
8   -my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
  8 +my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
9 9
10 10 %adaptee = ( -p3p => [qw/CAO DSP LAW CURa/] );
11 11 is $adapter{P3P}, 'policyref="/w3c/p3p.xml", CP="CAO DSP LAW CURa"';
4 t/16_content_disposition.t
... ... @@ -1,9 +1,9 @@
1 1 use strict;
2   -use CGI::Header::Entity;
  2 +use CGI::Header;
3 3 use Test::More tests => 18;
4 4
5 5 my %adaptee;
6   -my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
  6 +my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
7 7
8 8 %adaptee = ( -attachment => 'genome.jpg' );
9 9 is $adapter{Content_Disposition}, 'attachment; filename="genome.jpg"';
84 t/20_basic.t
@@ -3,7 +3,7 @@ use warnings;
3 3 use CGI::Header;
4 4 use CGI::Cookie;
5 5 use CGI::Util 'expires';
6   -use Test::More tests => 20;
  6 +use Test::More tests => 17;
7 7 use Test::Warn;
8 8 use Test::Exception;
9 9
@@ -12,8 +12,8 @@ my $class = 'CGI::Header';
12 12 ok $class->isa( 'CGI::Header' );
13 13
14 14 can_ok $class, qw(
15   - new clone clear delete exists get set is_empty as_hashref each flatten
16   - content_type date status
  15 + new clone clear delete exists get set is_empty each flatten
  16 + date status
17 17 DESTROY
18 18 );
19 19
@@ -48,8 +48,8 @@ ok !$header->exists('Bar'), 'should return false';
48 48 %header = ( -foo => 'bar', -bar => 'baz' );
49 49 is $header->get('Foo'), 'bar';
50 50 is $header->get('Baz'), undef;
51   -is $header->get('Foo', 'Bar'), 'baz';
52   -is_deeply [ $header->get('Foo', 'Bar') ], [ 'bar', 'baz' ];
  51 +#is $header->get('Foo', 'Bar'), 'baz';
  52 +#is_deeply [ $header->get('Foo', 'Bar') ], [ 'bar', 'baz' ];
53 53
54 54 # clear()
55 55 %header = ( -foo => 'bar' );
@@ -57,21 +57,21 @@ $header->clear;
57 57 is_deeply \%header, { -type => q{} }, 'should be empty';
58 58
59 59 subtest 'set()' => sub {
60   - my $expected = qr{^Odd number of elements passed to set\(\)};
61   - throws_ok { $header->set('Foo') } $expected;
  60 + #my $expected = qr{^Odd number of elements passed to set\(\)};
  61 + #throws_ok { $header->set('Foo') } $expected;
62 62
63 63 %header = ();
64 64
65 65 $header->set(
66 66 Foo => 'bar',
67   - Bar => 'baz',
68   - Baz => 'qux',
  67 + #Bar => 'baz',
  68 + #Baz => 'qux',
69 69 );
70 70
71 71 my %expected = (
72 72 -foo => 'bar',
73   - -bar => 'baz',
74   - -baz => 'qux',
  73 + #-bar => 'baz',
  74 + #-baz => 'qux',
75 75 );
76 76
77 77 is_deeply \%header, \%expected, 'set() multiple elements';
@@ -85,21 +85,21 @@ subtest 'delete()' => sub {
85 85 is $header->delete('Foo'), 'bar';
86 86 is_deeply \%header, {};
87 87
88   - %header = (
89   - -foo => 'bar',
90   - -bar => 'baz',
91   - );
  88 +#%header = (
  89 +# -foo => 'bar',
  90 +# -bar => 'baz',
  91 +# );
92 92
93   - is_deeply [ $header->delete('Foo', 'Bar') ], [ 'bar', 'baz' ];
94   - is_deeply \%header, {};
  93 +# is_deeply [ $header->delete('Foo', 'Bar') ], [ 'bar', 'baz' ];
  94 +# is_deeply \%header, {};
95 95
96   - %header = (
97   - -foo => 'bar',
98   - -bar => 'baz',
99   - );
  96 +# %header = (
  97 +# -foo => 'bar',
  98 +# -bar => 'baz',
  99 +# );
100 100
101   - ok $header->delete('Foo', 'Bar') eq 'baz';
102   - is_deeply \%header, {};
  101 +# ok $header->delete('Foo', 'Bar') eq 'baz';
  102 +# is_deeply \%header, {};
103 103 };
104 104
105 105 subtest 'each()' => sub {
@@ -163,31 +163,31 @@ subtest 'flatten()' => sub {
163 163 is_deeply \@got, \@expected;
164 164 };
165 165
166   -subtest 'as_hashref()' => sub {
167   - my $got = $header->as_hashref;
168   - ok ref $got eq 'HASH';
  166 +#subtest 'as_hashref()' => sub {
  167 +# my $got = $header->as_hashref;
  168 +# ok ref $got eq 'HASH';
169 169 #ok tied %{ $got } eq $header;
170 170
171   - %header = ();
172   - $header->{Foo} = 'bar';
173   - is_deeply \%header, { -foo => 'bar' }, 'store';
  171 +# %header = ();
  172 +# $header->{Foo} = 'bar';
  173 +# is_deeply \%header, { -foo => 'bar' }, 'store';
174 174
175   - %header = ( -foo => 'bar' );
176   - is $header->{Foo}, 'bar', 'fetch';
177   - is $header->{Bar}, undef;
  175 +# %header = ( -foo => 'bar' );
  176 +# is $header->{Foo}, 'bar', 'fetch';
  177 +# is $header->{Bar}, undef;
178 178
179   - %header = ( -foo => 'bar' );
180   - ok exists $header->{Foo}, 'exists';
181   - ok !exists $header->{Bar};
  179 +# %header = ( -foo => 'bar' );
  180 +# ok exists $header->{Foo}, 'exists';
  181 +# ok !exists $header->{Bar};
182 182
183   - %header = ( -foo => 'bar' );
184   - is delete $header->{Foo}, 'bar';
185   - is_deeply \%header, {}, 'delete';
  183 +# %header = ( -foo => 'bar' );
  184 +# is delete $header->{Foo}, 'bar';
  185 +# is_deeply \%header, {}, 'delete';
186 186
187   - %header = ( -foo => 'bar' );
188   - %{ $header } = ();
189   - is_deeply \%header, { -type => q{} }, 'clear';
190   -};
  187 +# %header = ( -foo => 'bar' );
  188 +# %{ $header } = ();
  189 +# is_deeply \%header, { -type => q{} }, 'clear';
  190 +#};
191 191
192 192 subtest 'status()' => sub {
193 193 %header = ();
34 t/21_content_type.t
... ... @@ -1,43 +1,11 @@
1 1 use strict;
2 2 use warnings;
3 3 use CGI::Header;
4   -use Test::More tests => 2;
  4 +use Test::More tests => 1;
5 5
6 6 my %adaptee;
7 7 my $adapter = CGI::Header->new( \%adaptee );
8 8
9   -#subtest 'charset()' => sub {
10   -# %adaptee = ();
11   -# is $adapter->charset, 'ISO-8859-1';
12   -
13   -# %adaptee = ( -charset => q{} );