From 48c4840be1f154e262de2c161cb86dc5000dfe47 Mon Sep 17 00:00:00 2001 From: Paul Seamons Date: Wed, 19 Jul 2006 00:00:00 +0000 Subject: [PATCH] CGI::Ex 2.05 --- Changes | 8 ++++++ META.yml | 2 +- lib/CGI/Ex.pm | 61 ++++++++++++++++++++++------------------- lib/CGI/Ex/App.pm | 2 +- lib/CGI/Ex/Auth.pm | 45 ++++++++++++++++++++++-------- lib/CGI/Ex/Conf.pm | 6 +++- lib/CGI/Ex/Dump.pm | 24 ++++++++-------- lib/CGI/Ex/Fill.pm | 2 +- lib/CGI/Ex/JSONDump.pm | 24 ++++++++-------- lib/CGI/Ex/Template.pm | 5 +++- lib/CGI/Ex/Template.pod | 34 +++++++++++------------ lib/CGI/Ex/Validate.pm | 2 +- t/7_template_00_base.t | 16 +++++------ 13 files changed, 137 insertions(+), 94 deletions(-) diff --git a/Changes b/Changes index fa799ac..67f99ea 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,11 @@ +2.05 2006-07-19 + * Allow for CGI::Ex to be compatible with Mandrake and Fedora mod_perl 2, as well as debian mod_perl2 + and older mod_perl1. + * Allow for CGI::Ex::Dump to localize the Data::Dumper options to not stomp on anybody elses toes. + * Update various perldoc bugs + * Fix JSONDump of \t and \r + * Change .as to .fmt to coincide with Perl6 (.as is still there - just not documented) + 2.04 2006-07-10 * Allow for items not in group order to get added to validation correctly in CGI::Ex::Validate. * Add samples/index.cgi diff --git a/META.yml b/META.yml index cb1be5c..b294eaa 100644 --- a/META.yml +++ b/META.yml @@ -1,7 +1,7 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: CGI-Ex -version: 2.04 +version: 2.05 version_from: lib/CGI/Ex.pm installdirs: site requires: diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index 955e26e..aae9e5d 100644 --- a/lib/CGI/Ex.pm +++ b/lib/CGI/Ex.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.04'; + $VERSION = '2.05'; $PREFERRED_CGI_MODULE ||= 'CGI'; @EXPORT = (); @EXPORT_OK = qw(get_form @@ -35,6 +35,34 @@ BEGIN { set_cookie location_bounce ); + + ### cache mod_perl version (light if or if not mod_perl) + my $v = (! $ENV{'MOD_PERL'}) ? 0 + # mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1 + # if MOD_PERL is set - don't die if regex fails - just assume 1.0 + : ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x) ? $1 + : '1.0_0'; + sub _mod_perl_version () { $v } + sub _is_mod_perl_1 () { $v < 1.98 && $v > 0 } + sub _is_mod_perl_2 () { $v >= 1.98 } + + ### cache apache request getter (light if or if not mod_perl) + my $sub; + if (_is_mod_perl_1) { # old mod_perl + require Apache; + $sub = sub { Apache->request }; + } elsif (_is_mod_perl_2) { + if (eval { require Apache2::RequestRec }) { # debian style + require Apache2::RequestUtil; + $sub = sub { Apache2::RequestUtil->request }; + } else { # fedora and mandrake style + require Apache::RequestUtil; + $sub = sub { Apache->request }; + } + } else { + $sub = sub {}; + } + sub apache_request_sub () { $sub } } ###----------------------------------------------------------------### @@ -197,37 +225,14 @@ sub apache_request { my $self = shift || die 'Usage: $cgix_obj->apache_request'; $self->{'apache_request'} = shift if $#_ != -1; - if (! $self->{'apache_request'}) { - if ($self->is_mod_perl_1) { - require Apache; - $self->{'apache_request'} = Apache->request; - } elsif ($self->is_mod_perl_2) { - require Apache2::RequestRec; - require Apache2::RequestUtil; - $self->{'apache_request'} = Apache2::RequestUtil->request; - } - } - - return $self->{'apache_request'}; + return $self->{'apache_request'} ||= apache_request_sub()->(); } ### Get the version of mod_perl running (0 if not mod_perl) # my $version = $cgix->mod_perl_version; -sub mod_perl_version { - my $self = shift || die 'Usage: $cgix_obj->mod_perl_version'; - - if (! defined $self->{'mod_perl_version'}) { - return 0 if ! $ENV{'MOD_PERL'}; - # mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1 - # if MOD_PERL is set - don't die if regex fails - just assume 1.0 - $self->{'mod_perl_version'} = ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x) - ? $1 : '1.0_0'; - } - return $self->{'mod_perl_version'}; -} - -sub is_mod_perl_1 { my $m = shift->mod_perl_version; return $m < 1.98 && $m > 0 } -sub is_mod_perl_2 { my $m = shift->mod_perl_version; return $m >= 1.98 } +sub mod_perl_version { _mod_perl_version } +sub is_mod_perl_1 { _is_mod_perl_1 } +sub is_mod_perl_2 { _is_mod_perl_2 } ### Allow for a setter # $cgix->set_apache_request($r) diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm index a08741d..4a62f92 100644 --- a/lib/CGI/Ex/App.pm +++ b/lib/CGI/Ex/App.pm @@ -10,7 +10,7 @@ use strict; use vars qw($VERSION); BEGIN { - $VERSION = '2.04'; + $VERSION = '2.05'; Time::HiRes->import('time') if eval {require Time::HiRes}; } diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index 337801c..b8be486 100644 --- a/lib/CGI/Ex/Auth.pm +++ b/lib/CGI/Ex/Auth.pm @@ -18,7 +18,7 @@ use MIME::Base64 qw(encode_base64 decode_base64); use Digest::MD5 qw(md5_hex); use CGI::Ex; -$VERSION = '2.04'; +$VERSION = '2.05'; ###----------------------------------------------------------------### @@ -728,18 +728,38 @@ __END__ =head1 SYNOPSIS - ### authorize the user - my $auth = $self->get_valid_auth({ - get_pass_by_user => \&get_pass_by_user, - }); + use CGI::Ex::Auth; + ### authorize the user + my $auth = CGI::Ex::Auth->get_valid_auth({ + get_pass_by_user => \&get_pass_by_user, + }); - sub get_pass_by_user { - my $auth = shift; - my $user = shift; - my $pass = some_way_of_getting_password($user); - return $pass; - } + + sub get_pass_by_user { + my $auth = shift; + my $user = shift; + my $pass = some_way_of_getting_password($user); + return $pass; + } + + ### OR - if you are using a OO based CGI or Application + + sub require_authentication { + my $self = shift; + + return $self->{'auth'} = CGI::Ex::Auth->get_valid_auth({ + get_pass_by_user => sub { + my ($auth, $user) = @_; + return $self->get_pass($user); + }, + }); + } + + sub get_pass { + my ($self, $user) = @_; + return $self->loopup_and_cache_pass($user); + } =head1 DESCRIPTION @@ -1049,7 +1069,8 @@ are not enabled, it may return the md5 sum of the password. get_pass_by_user => sub { my ($auth_obj, $user) = @_; - return $some_obj->get_pass({user => $user}); + my $pass = $some_obj->get_pass({user => $user}); + return $pass; } Alternately, get_pass_by_user may return a hashref of data items that diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index 322fd1c..60b2d99 100644 --- a/lib/CGI/Ex/Conf.pm +++ b/lib/CGI/Ex/Conf.pm @@ -28,7 +28,7 @@ use vars qw($VERSION ); @EXPORT_OK = qw(conf_read conf_write in_cache); -$VERSION = '2.04'; +$VERSION = '2.05'; $DEFAULT_EXT = 'conf'; @@ -866,6 +866,10 @@ Should be a windows style ini file. See L Should be an xml file. It will be read in by XMLin. See L. +=item C + +Should be a json file. It will be read using the JSON library. See L. + =item C and C This is actually a custom type intended for use with CGI::Ex::Validate. diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm index c4d49f9..af5a00b 100644 --- a/lib/CGI/Ex/Dump.pm +++ b/lib/CGI/Ex/Dump.pm @@ -13,11 +13,11 @@ CGI::Ex::Dump - A debug utility use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $CALL_LEVEL - $ON $SUB $QR1 $QR2 $full_filename); + $ON $SUB $QR1 $QR2 $full_filename $DEPARSE); use strict; use Exporter; -$VERSION = '2.04'; +$VERSION = '2.05'; @ISA = qw(Exporter); @EXPORT = qw(dex dex_warn dex_text dex_html ctrace dex_trace); @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug); @@ -25,22 +25,22 @@ $VERSION = '2.04'; ### is on or off sub on { $ON = 1 }; sub off { $ON = 0; } -&on(); -sub set_deparse { - $Data::Dumper::Deparse = eval {require B::Deparse}; -} +sub set_deparse { $DEPARSE = 1 } ###----------------------------------------------------------------### BEGIN { - ### setup the Data::Dumper usage - $Data::Dumper::Sortkeys = 1 if ! defined $Data::Dumper::Sortkeys; # not avail pre 5.8 - $Data::Dumper::Useqq = 1 if ! defined $Data::Dumper::Useqq; - $Data::Dumper::Quotekeys = 0 if ! defined $Data::Dumper::Quotekeys; - $Data::Dumper::Pad = ' ' if ! defined $Data::Dumper::Pad; - #$Data::Dumper::Deparse = 1 if ! defined $Data::Dumper::Deparse; # very useful + on(); + $SUB = sub { + ### setup the Data::Dumper usage + local $Data::Dumper::Deparse = $DEPARSE && eval {require B::Deparse}; + local $Data::Dumper::Pad = ' '; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Useqq = 1; + local $Data::Dumper::Quotekeys = 0; + require Data::Dumper; return Data::Dumper->Dumpperl(\@_); }; diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm index 191f392..65cfa29 100644 --- a/lib/CGI/Ex/Fill.pm +++ b/lib/CGI/Ex/Fill.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.04'; + $VERSION = '2.05'; @EXPORT = qw(form_fill); @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key); }; diff --git a/lib/CGI/Ex/JSONDump.pm b/lib/CGI/Ex/JSONDump.pm index fe7c562..69222bf 100644 --- a/lib/CGI/Ex/JSONDump.pm +++ b/lib/CGI/Ex/JSONDump.pm @@ -17,7 +17,7 @@ use strict; use base qw(Exporter); BEGIN { - $VERSION = '2.04'; + $VERSION = '2.05'; @EXPORT = qw(JSONDump); @EXPORT_OK = @EXPORT; @@ -108,8 +108,8 @@ sub js_escape { my $quote = $self->{'single_quote'} ? "'" : '"'; $str =~ s/\\/\\\\/g; - $str =~ s/\r/\\\r/g; - $str =~ s/\t/\\\t/g; + $str =~ s/\r/\\r/g; + $str =~ s/\t/\\t/g; $self->{'single_quote'} ? $str =~ s/\'/\\\'/g : $str =~ s/\"/\\\"/g; ### allow for really odd chars @@ -238,7 +238,7 @@ include whitespace to make them more readable. with single quotes. Otherwise values are quoted with double quotes. JSONDump("a", {single_quote => 0}); - JSONDump('a', {single_quote => 0}); + JSONDump("a", {single_quote => 1}); Would print @@ -249,7 +249,7 @@ with single quotes. Otherwise values are quoted with double quotes. 0 or 1. Default 1 (true) -If true, then key/value pairs of hashrefs will be sorted will be output in sorted order. +If true, then key/value pairs of hashrefs will be output in sorted order. =item play_coderefs @@ -294,9 +294,10 @@ with unknown types will not be included in the javascript output. =item skip_keys -Should contain an arrayref of keys or a hashref whose keys are the keys to skip. Default -is unset. Any keys of hashrefs that are in the skip_keys item will not be included in -the javascript output. +Should contain an arrayref of keys or a hashref whose keys are the +keys to skip. Default is unset. Any keys of hashrefs (including +nested hashrefs) that are in the skip_keys item will not be included +in the javascript output. JSONDump({a => 1, b => 1}, {skip_keys => ['a'], pretty => 0}); @@ -306,8 +307,9 @@ the javascript output. =item skip_keys_qr -Similar to skip_keys but should contain a regex. Any keys of hashrefs that match the -skip_keys_qr regex will not be included in the javascript output. +Similar to skip_keys but should contain a regex. Any keys of hashrefs +(including nested hashrefs) that match the skip_keys_qr regex will not +be included in the javascript output. JSONDump({a => 1, _b => 1}, {skip_keys_qr => qr/^_/, pretty => 0}); @@ -346,7 +348,7 @@ greater than 80 characters. Default is "\n". +"with plenty of embedded newlines\n" +"and is greater than 80 characters.\n" -If the string is less than 80 characters, or if str_nl is set to '', then the escaped +If the string is less than 80 characters, or if str_nl is set to "", then the escaped string will be contained on a single line. =back diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 6c95025..52d92a0 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -39,7 +39,7 @@ use vars qw($VERSION ); BEGIN { - $VERSION = '2.04'; + $VERSION = '2.05'; $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception'; $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator'; @@ -66,6 +66,7 @@ BEGIN { defined => sub { 1 }, indent => \&vmethod_indent, int => sub { local $^W; int $_[0] }, + fmt => \&vmethod_as_scalar, 'format' => \&vmethod_format, hash => sub { {value => $_[0]} }, html => sub { local $_ = $_[0]; s/&/&/g; s//>/g; s/\"/"/g; $_ }, @@ -101,6 +102,7 @@ BEGIN { $LIST_OPS = { as => \&vmethod_as_list, first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]}, + fmt => \&vmethod_as_list, grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] }, hash => sub { local $^W; my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} }, join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref }, @@ -129,6 +131,7 @@ BEGIN { delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } }, each => sub { [%{ $_[0] }] }, exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } }, + fmt => \&vmethod_as_hash, hash => sub { $_[0] }, import => sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' }, item => sub { my ($h, $k) = @_; return '' if ! defined $k || $k =~ $QR_PRIVATE; $h->{$k} }, diff --git a/lib/CGI/Ex/Template.pod b/lib/CGI/Ex/Template.pod index 83545c4..9d2c3c6 100644 --- a/lib/CGI/Ex/Template.pod +++ b/lib/CGI/Ex/Template.pod @@ -272,11 +272,11 @@ to virtual methods. | Hash.keys | List.join(", ") %] # = a, b -=item Added "as" scalar, list, and hash virtual methods. +=item Added "fmt" scalar, list, and hash virtual methods. - [% list.as("%s", ", ") %] + [% list.fmt("%s", ", ") %] - [% hash.as("%s => %s", "\n") %] + [% hash.fmt("%s => %s", "\n") %] =item Whitespace is less meaningful. (TT3) @@ -306,13 +306,13 @@ to virtual methods. [% a = 1.2e-20 %] - [% 123.as('%.3e') %] # = 1.230e+02 + [% 123.fmt('%.3e') %] # = 1.230e+02 =item Allow for hexidecimal input. (TT3) [% a = 0xff0000 %][% a %] # = 16711680 - [% a = 0xff2 / 0xd; a.as('%x') %] # = 13a + [% a = 0xff2 / 0xd; a.fmt('%x') %] # = 13a =item FOREACH variables can be nested. @@ -628,13 +628,13 @@ Scientific notation is supported. [% 314159e-5 + 0 %] Prints 3.14159. - [% .0000001.as('%.1e') %] Prints 1.0e-07 + [% .0000001.fmt('%.1e') %] Prints 1.0e-07 Hexidecimal input is also supported. [% 0xff + 0 %] Prints 255 - [% 48875.as('%x') %] Prints beeb + [% 48875.fmt('%x') %] Prints beeb =item Single quoted strings. @@ -750,12 +750,6 @@ object (except for true filters such as eval and redirect). [% item = 'foo' %][% item.0 %] Returns self. Allows for scalars to mask as arrays (scalars already will, but this allows for more direct access). -=item as - - [% item.as('%d') %] - -Similar to format. Returns a string formatted with the passed pattern. Default pattern is %s. - =item chunk [% item.chunk(60).join("\n") %] Split string up into a list of chunks of text 60 chars wide. @@ -792,6 +786,12 @@ This is a filter and is not available via the Text virtual object. Same as the redirect filter. +=item fmt + + [% item.fmt('%d') %] + +Similar to format. Returns a string formatted with the passed pattern. Default pattern is %s. + =item format [% item.format('%d') %] Print the string out in the specified format. It is similar to @@ -925,9 +925,9 @@ Virtual Object. =over 4 -=item as +=item fmt - [% mylist.as('%s', ', ') %] + [% mylist.fmt('%s', ', ') %] Passed a pattern and an string to join on. Returns a string of the values of the list formatted with the passed pattern and joined with the passed string. @@ -1033,9 +1033,9 @@ Virtual Object. =over 4 -=item as +=item fmt - [% myhash.as('%s => %s', "\n") %] + [% myhash.fmt('%s => %s', "\n") %] Passed a pattern and an string to join on. Returns a string of the key/value pairs of the hash formatted with the passed pattern and joined with the passed string. diff --git a/lib/CGI/Ex/Validate.pm b/lib/CGI/Ex/Validate.pm index 16591d5..77ebd2a 100644 --- a/lib/CGI/Ex/Validate.pm +++ b/lib/CGI/Ex/Validate.pm @@ -22,7 +22,7 @@ use vars qw($VERSION @UNSUPPORTED_BROWSERS ); -$VERSION = '2.04'; +$VERSION = '2.05'; $DEFAULT_EXT = 'val'; $QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/; diff --git a/t/7_template_00_base.t b/t/7_template_00_base.t index 85065cf..9481952 100644 --- a/t/7_template_00_base.t +++ b/t/7_template_00_base.t @@ -350,16 +350,16 @@ process_ok('[% ["a".."z"].${ 26.rand } %]' => qr/^[a-z]/) if ! $is_tt; process_ok("[% ' ' | uri %]" => '%20'); -process_ok('[% "one".as %]' => "one") if ! $is_tt; -process_ok('[% 2.as("%02d") %]' => "02") if ! $is_tt; +process_ok('[% "one".fmt %]' => "one") if ! $is_tt; +process_ok('[% 2.fmt("%02d") %]' => "02") if ! $is_tt; -process_ok('[% [1..3].as %]' => "1 2 3") if ! $is_tt; -process_ok('[% [1..3].as("%02d") %]' => '01 02 03') if ! $is_tt; -process_ok('[% [1..3].as("%s", ", ") %]' => '1, 2, 3') if ! $is_tt; +process_ok('[% [1..3].fmt %]' => "1 2 3") if ! $is_tt; +process_ok('[% [1..3].fmt("%02d") %]' => '01 02 03') if ! $is_tt; +process_ok('[% [1..3].fmt("%s", ", ") %]' => '1, 2, 3') if ! $is_tt; -process_ok('[% {a => "B", c => "D"}.as %]' => "a\tB\nc\tD") if ! $is_tt; -process_ok('[% {a => "B", c => "D"}.as("%s:%s") %]' => "a:B\nc:D") if ! $is_tt; -process_ok('[% {a => "B", c => "D"}.as("%s:%s", "; ") %]' => "a:B; c:D") if ! $is_tt; +process_ok('[% {a => "B", c => "D"}.fmt %]' => "a\tB\nc\tD") if ! $is_tt; +process_ok('[% {a => "B", c => "D"}.fmt("%s:%s") %]' => "a:B\nc:D") if ! $is_tt; +process_ok('[% {a => "B", c => "D"}.fmt("%s:%s", "; ") %]' => "a:B; c:D") if ! $is_tt; ###----------------------------------------------------------------### ### virtual objects -- 2.45.2