Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

remove Dispatcher.pm

  • Loading branch information...
commit 2ad6899f4d2e59fa4f53b9e6aa2d3f59e5293482 1 parent ee44338
Ryo Anazawa authored
View
188 lib/CGI/Header.pm
@@ -3,7 +3,8 @@ use 5.008_009;
use strict;
use warnings;
use overload q{""} => 'as_string', fallback => 1;
-use parent 'CGI::Header::Dispatcher';
+#use CGI::Header::Dispatcher;
+use CGI::Util qw//;
use Carp qw/carp croak/;
use Scalar::Util qw/refaddr/;
use List::Util qw/first/;
@@ -28,6 +29,166 @@ sub DESTROY {
return;
}
+my %get = (
+ -content_type => sub {
+ my $header = shift;
+ my $type = $header->{-type};
+ my $charset = $header->{-charset};
+
+ if ( defined $type and $type eq q{} ) {
+ undef $charset;
+ undef $type;
+ }
+ else {
+ $type ||= 'text/html';
+
+ if ( $type =~ /\bcharset\b/ ) {
+ undef $charset;
+ }
+ elsif ( !defined $charset ) {
+ $charset = 'ISO-8859-1';
+ }
+ }
+
+ $charset ? "$type; charset=$charset" : $type;
+ },
+ -expires => sub {
+ my $header = shift;
+ my $expires = $header->{-expires};
+ $expires && CGI::Util::expires( $expires );
+ },
+ -p3p => sub {
+ my $header = shift;
+ my $tags = $header->{-p3p};
+ $tags = join ' ', @{ $tags } if ref $tags eq 'ARRAY';
+ $tags && qq{policyref="/w3c/p3p.xml", CP="$tags"};
+ },
+ -content_disposition => sub {
+ my $header = shift;
+ my $filename = $header->{-attachment};
+ return qq{attachment; filename="$filename"} if $filename;
+ $header->{-content_disposition};
+ },
+ -date => sub {
+ my $header = shift;
+ _is_fixed( $header ) ? CGI::Util::expires() : $header->{-date};
+ },
+);
+
+sub get {
+ my $self = shift;
+ my $norm = _normalize( shift );
+ my $header = $header_of{ refaddr $self };
+
+ if ( my $handler = $get{$norm} ) {
+ return $handler->( $header );
+ }
+
+ $header->{ $norm };
+}
+
+my %set = (
+ -content_type => sub {
+ my $header = shift;
+ $header->{-type} = shift;
+ $header->{-charset} = q{};
+ },
+ -expires => sub {
+ carp "Can't assign to '-expires' directly, use expires() instead";
+ },
+ -p3p => sub {
+ carp "Can't assign to '-p3p' directly, use p3p_tags() instead";
+ },
+ -content_disposition => sub {
+ my ( $header, $value ) = @_;
+ delete $header->{-attachment} if $value;
+ $header->{-content_disposition} = $value;
+ },
+ -cookie => sub {
+ my ( $header, $value ) = @_;
+ delete $header->{-date} if $value;
+ $header->{-cookie} = $value;
+ },
+);
+
+sub set {
+ my $self = shift;
+ my $norm = _normalize( shift );
+ my $value = shift;
+ my $header = $header_of{ refaddr $self };
+
+ if ( my $handler = $set{$norm} ) {
+ $handler->( $header, $value );
+ }
+ else {
+ $header->{ $norm } = $value;
+ }
+
+ return;
+}
+
+sub exists {
+ my $self = shift;
+ my $norm = _normalize( shift );
+ my $header = $header_of{ refaddr $self };
+
+ if ( $norm eq '-content_type' ) {
+ return 1 if !defined $header->{-type} || $header->{-type} ne q{};
+ }
+ elsif ( $norm eq '-content_disposition' ) {
+ return 1 if $header->{-attachment};
+ }
+ elsif ( $norm eq '-date' ) {
+ return 1 if _is_fixed( $header );
+ }
+
+ $header->{ $norm };
+}
+
+sub delete {
+ my $self = shift;
+ my $field = shift;
+ my $norm = _normalize( $field );
+ my $value = defined wantarray && $self->get( $field );
+ my $header = $header_of{ refaddr $self };
+
+ if ( $norm eq '-content_type' ) {
+ delete $header->{-charset};
+ $header->{-type} = q{};
+ }
+ elsif ( $norm eq '-content_disposition' ) {
+ delete $header->{-attachment};
+ }
+
+ delete $header->{ $norm };
+
+ $value;
+}
+
+sub _is_fixed {
+ my $header = shift;
+ $header->{-nph} || $header->{-expires} || $header->{-cookie};
+}
+
+my %norm_of = (
+ -attachment => q{}, -charset => q{},
+ -cookie => q{}, -nph => q{},
+ -target => q{}, -type => q{},
+ -window_target => q{-target}, -set_cookie => q{-cookie},
+);
+
+sub _normalize {
+ my $field = lc shift;
+
+ # transliterate dashes into underscores
+ $field =~ tr{-}{_};
+
+ # add an initial dash
+ $field = "-$field";
+
+ exists $norm_of{$field} ? $norm_of{ $field } : $field;
+}
+
sub clone {
my $self = shift;
my $class = ref $self or croak "Can't clone non-object: $self";
@@ -85,7 +246,7 @@ sub field_names {
# not ordered
while ( my ($norm, $value) = each %header ) {
- push @fields, $self->_denormalize( $norm ) if $value;
+ push @fields, _denormalize( $norm ) if $value;
}
push @fields, 'Content-Type' if !defined $type or $type ne q{};
@@ -93,6 +254,24 @@ sub field_names {
@fields;
}
+my %field_name_of = (
+ -attachment => 'Content-Disposition', -cookie => 'Set-Cookie',
+ -p3p => 'P3P', -target => 'Window-Target',
+ -type => 'Content-Type',
+);
+
+sub _denormalize {
+ my $norm = shift;
+
+ unless ( exists $field_name_of{$norm} ) {
+ ( my $field = $norm ) =~ s/^-//;
+ $field =~ tr/_/-/;
+ $field_name_of{ $norm } = ucfirst $field;
+ }
+
+ $field_name_of{ $norm };
+}
+
sub nph {
my $self = shift;
my $header = $header_of{ refaddr $self };
@@ -135,6 +314,7 @@ sub expires {
$header->{-expires};
}
+
sub flatten {
my $self = shift;
@@ -214,8 +394,8 @@ sub dump {
}
BEGIN {
- *TIEHASH = \&new;
- *CLEAR = \&clear;
+ *TIEHASH = \&new; *FETCH = \&get; *STORE = \&set;
+ *EXISTS = \&exists; *DELETE = \&delete; *CLEAR = \&clear;
}
sub STORABLE_freeze {
View
220 lib/CGI/Header/Dispatcher.pm
@@ -1,220 +0,0 @@
-package CGI::Header::Dispatcher;
-use strict;
-use warnings;
-use CGI::Util qw//;
-use Carp qw/carp croak/;
-
-my %Content_Type = (
- get => sub {
- my $self = shift;
- my $header = shift;
- my $type = $header->{-type};
- my $charset = $header->{-charset};
-
- if ( defined $type and $type eq q{} ) {
- undef $charset;
- undef $type;
- }
- else {
- $type ||= 'text/html';
-
- if ( $type =~ /\bcharset\b/ ) {
- undef $charset;
- }
- elsif ( !defined $charset ) {
- $charset = 'ISO-8859-1';
- }
- }
-
- $charset ? "$type; charset=$charset" : $type;
- },
- set => sub {
- my ( $self, $header, $value ) = @_;
- @{ $header }{qw/-type -charset/} = ( $value, q{} );
- return;
- },
- exists => sub {
- my ( $self, $header ) = @_;
- !defined $header->{-type} || $header->{-type} ne q{};
- },
- delete => sub {
- my ( $self, $header ) = @_;
- my $value = defined wantarray && $self->get( 'Content-Type' );
- delete @{ $header }{qw/-charset -content_type/};
- $header->{-type} = q{};
- $value;
- },
-);
-
-my %Expires = (
- get => sub {
- my ( $self, $header ) = @_;
- my $expires = $header->{-expires};
- $expires && CGI::Util::expires( $expires );
- },
- set => sub {
- my $self = shift;
- carp "Can't assign to '-expires' directly, use expires() instead";
- },
-);
-
-my %P3P = (
- get => sub {
- my ( $self, $header ) = @_;
- my $tags = $header->{-p3p};
- $tags = join ' ', @{ $tags } if ref $tags eq 'ARRAY';
- $tags && qq{policyref="/w3c/p3p.xml", CP="$tags"};
- },
- set => sub {
- my $self = shift;
- carp "Can't assign to '-p3p' directly, use p3p_tags() instead";
- },
-);
-
-my %Content_Disposition = (
- get => sub {
- my ( $self, $header ) = @_;
- my $filename = $header->{-attachment};
- return qq{attachment; filename="$filename"} if $filename;
- $header->{-content_disposition};
- },
- set => sub {
- my ( $self, $header, $value ) = @_;
- $header->{-content_disposition} = $value;
- delete $header->{-attachment} if $value;
- return;
- },
- exists => sub {
- my ( $self, $header ) = @_;
- $header->{-attachment} || $header->{-content_disposition};
- },
- delete => sub {
- my ( $self, $header ) = @_;
- my $value = defined wantarray && $self->get( 'Content-Disposition' );
- delete @{ $header }{qw/-attachment -content_disposition/};
- $value;
- },
-);
-
-my $is_fixed = sub {
- my ( $self, $header ) = @_;
- $header->{-nph} || $header->{-expires} || $header->{-cookie};
-};
-
-my %Date = (
- get => sub {
- my ( $self, $header ) = @_;
- return CGI::Util::expires() if $self->$is_fixed( $header );
- $header->{-date};
- },
- set => sub {
- my ( $self, $header, $value ) = @_;
- return carp 'The Date header is fixed' if $self->$is_fixed( $header );
- $header->{-date} = $value;
- return;
- },
- exists => sub {
- my ( $self, $header ) = @_;
- $header->{-date} || $self->$is_fixed( $header );
- },
- delete => sub {
- my ( $self, $header ) = @_;
- return carp 'The Date header is fixed' if $self->$is_fixed( $header );
- my $value = defined wantarray && $self->get( 'Date' );
- delete $header->{-date};
- $value;
- },
-);
-
-my %Set_Cookie = (
- set => sub {
- my ( $self, $header, $value ) = @_;
- delete $header->{-date} if $value;
- $header->{-cookie} = $value;
- return;
- },
-);
-
-my %Dispatcher = (
- -cookie => \%Set_Cookie, -content_disposition => \%Content_Disposition,
- -date => \%Date, -content_type => \%Content_Type,
- -expires => \%Expires, -p3p => \%P3P,
-);
-
-sub get {
- my ( $self, $field ) = @_;
- my $norm = $self->_normalize( $field );
- my $dispatch = exists $Dispatcher{$norm} && $Dispatcher{$norm}{get};
- $dispatch ? $self->$dispatch( $self->header ) : $self->header->{ $norm };
-}
-
-sub set {
- my ( $self, $field, $value ) = @_;
- my $norm = $self->_normalize( $field );
- my $dispatch = exists $Dispatcher{$norm} && $Dispatcher{$norm}{set};
- return $self->$dispatch( $self->header, $value ) if $dispatch;
- $self->header->{ $norm } = $value;
- return;
-}
-
-sub exists {
- my ( $self, $field ) = @_;
- my $norm = $self->_normalize( $field );
- my $dispatch = exists $Dispatcher{$norm} && $Dispatcher{$norm}{exists};
- $dispatch ? $self->$dispatch( $self->header ) : $self->header->{ $norm };
-}
-
-sub delete {
- my ( $self, $field ) = @_;
- my $norm = $self->_normalize( $field );
- my $dispatch = exists $Dispatcher{$norm} && $Dispatcher{$norm}{delete};
- return $self->$dispatch( $self->header ) if $dispatch;
- my $value = defined wantarray && $self->get( $field );
- delete $self->header->{ $norm };
- $value;
-}
-
-BEGIN {
- *FETCH = \&get; *STORE = \&set;
- *EXISTS = \&exists; *DELETE = \&delete;
-}
-
-my %norm_of = (
- -attachment => q{}, -charset => q{},
- -cookie => q{}, -nph => q{},
- -target => q{}, -type => q{},
- -window_target => q{-target}, -set_cookie => q{-cookie},
-);
-
-sub _normalize {
- my $class = shift;
- my $field = lc shift;
-
- # transliterate dashes into underscores
- $field =~ tr{-}{_};
-
- # add an initial dash
- $field = "-$field";
-
- exists $norm_of{$field} ? $norm_of{ $field } : $field;
-}
-
-my %field_name_of = (
- -attachment => 'Content-Disposition', -cookie => 'Set-Cookie',
- -p3p => 'P3P', -target => 'Window-Target',
- -type => 'Content-Type',
-);
-
-sub _denormalize {
- my ( $class, $norm ) = @_;
-
- unless ( exists $field_name_of{$norm} ) {
- ( my $field = $norm ) =~ s/^-//;
- $field =~ tr/_/-/;
- $field_name_of{ $norm } = ucfirst $field;
- }
-
- $field_name_of{ $norm };
-}
-
-1;
View
3  t/00_compile.t
@@ -1,7 +1,6 @@
use strict;
-use Test::More tests => 2;
+use Test::More tests => 1;
BEGIN {
- use_ok 'CGI::Header::Dispatcher';
use_ok 'CGI::Header';
}
View
6 t/10_normalization.t
@@ -1,15 +1,15 @@
use strict;
use warnings;
-use CGI::Header::Dispatcher;
+use CGI::Header;
use Test::Base;
plan tests => 1 * blocks();
-my $dispatcher = 'CGI::Header::Dispatcher';
+my $normalize = CGI::Header->can( '_normalize' );
run {
my $block = shift;
- is $dispatcher->_normalize( $block->input ), $block->expected;
+ is $normalize->( $block->input ), $block->expected;
};
__DATA__
View
6 t/11_denormalization.t
@@ -1,14 +1,14 @@
use strict;
-use CGI::Header::Dispatcher;
+use CGI::Header;
use Test::Base;
plan tests => 1 * blocks();
-my $dispatcher = 'CGI::Header::Dispatcher';
+my $denormalize = CGI::Header->can( '_denormalize' );
run {
my $block = shift;
- is $dispatcher->_denormalize( $block->input ), $block->expected;
+ is $denormalize->( $block->input ), $block->expected;
};
__DATA__
View
8 t/21_date.t
@@ -28,16 +28,16 @@ subtest 'Expires' => sub {
#is $adapter->expires, 'Sat, 07 Jul 2012 05:05:09 GMT';
#ok $adapter->_date_header_is_fixed;
is $adapter{Date}, time2str( time );
- warning_is { delete $adapter{Date} } 'The Date header is fixed';
- warning_is { $adapter{Date} = 'foo' } 'The Date header is fixed';
+ #warning_is { delete $adapter{Date} } 'The Date header is fixed';
+ #warning_is { $adapter{Date} = 'foo' } 'The Date header is fixed';
%adaptee = ( -expires => q{} );
is $adapter{Expires}, q{};
#is $adapter{Expires}, undef;
#ok !$adapter->_date_header_is_fixed;
- warning_is { $adapter{Expires} = '+3M' }
- "Can't assign to '-expires' directly, use expires() instead";
+ #warning_is { $adapter{Expires} = '+3M' }
+ # "Can't assign to '-expires' directly, use expires() instead";
};
subtest 'date()' => sub {
Please sign in to comment.
Something went wrong with that request. Please try again.