From: Paul Seamons Date: Mon, 10 Jul 2006 00:00:00 +0000 (+0000) Subject: CGI::Ex 2.04 X-Git-Tag: v2.04 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=d710d6cd21be21c0ab2df3566c2bd61d9015cac6;p=chaz%2Fp5-CGI-Ex CGI::Ex 2.04 --- diff --git a/Changes b/Changes index 3e7bee4..fa799ac 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,12 @@ +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 + * Fix samples/app/cgi_ex_* to actually work. + * Added CGI::Ex::JSONDump + * Change Validate to use JSONDump instaed of JSON + * Various perldoc and other bug fixes. + * Removed CGI-Ex.spec - use cpan2rpm or cpan2deb instead. + 2.03 2006-06-10 * Fix the associativity of operators in Template to match perl * Allow for multiple prefix operators. diff --git a/MANIFEST b/MANIFEST index d57f9bd..2772de7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,4 +1,3 @@ -CGI-Ex.spec Changes lib/CGI/Ex.pm lib/CGI/Ex/App.pm @@ -8,6 +7,7 @@ lib/CGI/Ex/Conf.pm lib/CGI/Ex/Die.pm lib/CGI/Ex/Dump.pm lib/CGI/Ex/Fill.pm +lib/CGI/Ex/JSONDump.pm lib/CGI/Ex/md5.js lib/CGI/Ex/sha1.js lib/CGI/Ex/Template.pm @@ -20,18 +20,19 @@ MANIFEST MANIFEST.SKIP META.yml README +samples/app/cgi_ex_1.cgi +samples/app/cgi_ex_2.cgi samples/benchmark/bench_auth.pl samples/benchmark/bench_cgix_hfif.pl samples/benchmark/bench_conf_readers.pl samples/benchmark/bench_conf_writers.pl +samples/benchmark/bench_jsondump.pl samples/benchmark/bench_method_calling.pl samples/benchmark/bench_optree.pl samples/benchmark/bench_template.pl samples/benchmark/bench_template_tag_parser.pl samples/benchmark/bench_validation.pl samples/benchmark/bench_various_templaters.pl -samples/cgi_ex_1.cgi -samples/cgi_ex_2.cgi samples/conf_path_1/apples.pl samples/conf_path_1/oranges.pl samples/conf_path_3/apples.pl @@ -42,6 +43,7 @@ samples/devel/dprof_validation.d samples/generate_js.pl samples/html1.htm samples/html2.htm +samples/index.cgi samples/js_validate_1.html samples/js_validate_2.html samples/js_validate_3.html @@ -93,3 +95,4 @@ t/6_die_00_base.t t/7_template_00_base.t t/7_template_01_includes.t t/8_auth_00_base.t +t/9_jsondump_00_base.t diff --git a/META.yml b/META.yml index 7dff86d..cb1be5c 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.03 +version: 2.04 version_from: lib/CGI/Ex.pm installdirs: site requires: diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index e009324..955e26e 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.03'; + $VERSION = '2.04'; $PREFERRED_CGI_MODULE ||= 'CGI'; @EXPORT = (); @EXPORT_OK = qw(get_form diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm index 0c3b1f7..a08741d 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.03'; + $VERSION = '2.04'; Time::HiRes->import('time') if eval {require Time::HiRes}; } @@ -382,6 +382,8 @@ sub run_hook { my ($code, $found) = @{ $self->find_hook($hook, $step) }; if (! $code) { croak "Could not find a method named ${step}_${hook} or ${hook}"; + } elsif (! UNIVERSAL::isa($code, 'CODE')) { + croak "Value for $hook ($found) is not a code ref ($code)"; } ### record history diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index 67605ff..337801c 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.03'; +$VERSION = '2.04'; ###----------------------------------------------------------------### @@ -315,7 +315,9 @@ sub login_hash_common { $self->key_time => $self->server_time, $self->key_payload => $self->generate_payload({%$data, login_form => 1}), $self->key_expires_min => $self->expires_min, - + text_user => $self->text_user, + text_pass => $self->text_pass, + text_save => $self->text_save, }; } @@ -337,7 +339,7 @@ sub verify_token { my $key; for my $armor ('none', 'base64', 'blowfish') { # try with and without base64 encoding my $copy = ($armor eq 'none') ? $token - : ($armor eq 'base64') ? decode_base64($token) + : ($armor eq 'base64') ? eval { local $^W; decode_base64($token) } : ($key = $self->use_blowfish) ? decrypt_blowfish($token, $key) : next; if ($copy =~ m|^ ([^/]+) / (\d+) / (-?\d+) / (.*) / ([a-fA-F0-9]{32}) (?: / (sh\.\d+\.\d+))? $|x) { @@ -383,6 +385,13 @@ sub verify_token { } elsif (! defined($pass = eval { $self->get_pass_by_user($data->{'user'}) })) { $data->add_data({details => $@}); $data->error('Could not get pass'); + } elsif (ref $pass eq 'HASH') { + my $extra = $pass; + $pass = exists($extra->{'real_pass'}) ? delete($extra->{'real_pass'}) + : exists($extra->{'password'}) ? delete($extra->{'password'}) + : do { $data->error('Data returned by get_pass_by_user did not contain real_pass or password'); undef }; + $data->error('Invalid login') if ! defined $pass && ! $data->error; + $data->add_data($extra); } return $data if $data->error; @@ -622,16 +631,16 @@ sub login_form { - + - + @@ -645,6 +654,10 @@ sub login_form { }; } +sub text_user { my $self = shift; return defined($self->{'text_user'}) ? $self->{'text_user'} : 'Username:' } +sub text_pass { my $self = shift; return defined($self->{'text_pass'}) ? $self->{'text_pass'} : 'Password:' } +sub text_save { my $self = shift; return defined($self->{'text_save'}) ? $self->{'text_save'} : 'Save Password ?' } + sub login_script { return q { [%~ IF ! use_plaintext %] @@ -797,6 +810,9 @@ defined separately. secure_hash_keys template_args template_include_path + text_user + text_pass + text_save use_base64 use_blowfish use_crypt @@ -946,6 +962,9 @@ Passed to the template swapped during login_print. $self->key_time # $self->server_time, # the server's time $self->key_payload # $data->{'payload'} # the payload (if any) $self->key_expires_min # $self->expires_min # how many minutes crams are valid + text_user # $self->text_user # template text Username: + text_pass # $self->text_pass # template text Password: + text_save # $self->text_save # template text Save Password ? =item C @@ -1028,6 +1047,26 @@ valid password for the user. It can always return plaintext. If use_crypt is enabled, it should return the crypted password. If use_plaintext and use_crypt 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}); + } + +Alternately, get_pass_by_user may return a hashref of data items that +will be added to the data object if the token is valid. The hashref +must also contain a key named real_pass or password that contains the +password. Note that keys passed back in the hashref that are already +in the data object will override those in the data object. + + get_pass_by_user => sub { + my ($auth_obj, $user) = @_; + my ($pass, $user_id) = $some_obj->get_pass({user => $user}); + return { + password => $pass, + user_id => $user_id, + }; + } + =item C Returns a CGI::Ex object. @@ -1080,8 +1119,18 @@ Contains javascript that will attach to the form from login_form. This script is capable of taking the login_fields and creating an md5 cram which prevents the password from being passed plaintext. +=item C + +The text items shown in the default login template. The default values are: + + text_user "Username:" + text_pass "Password:" + text_save "Save Password ?" + +=back + =head1 AUTHORS -Paul Seamons +Paul Seamons =cut diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index 787be6f..322fd1c 100644 --- a/lib/CGI/Ex/Conf.pm +++ b/lib/CGI/Ex/Conf.pm @@ -26,9 +26,9 @@ use vars qw($VERSION $HTML_KEY @EXPORT_OK ); -@EXPORT_OK = qw(conf_read conf_write); +@EXPORT_OK = qw(conf_read conf_write in_cache); -$VERSION = '2.03'; +$VERSION = '2.04'; $DEFAULT_EXT = 'conf'; @@ -583,47 +583,52 @@ sub write_handler_html { ###----------------------------------------------------------------### sub preload_files { - my $self = shift; - my $paths = shift || $self->paths; - require File::Find; - - ### what extensions do we look for - my %EXT; - if ($self->{handler}) { - if (UNIVERSAL::isa($self->{handler},'HASH')) { - %EXT = %{ $self->{handler} }; - } - } else { - %EXT = %EXT_READERS; - if (! $self->{html_key} && ! $HTML_KEY) { - delete $EXT{$_} foreach qw(html htm); - } - } - return if ! keys %EXT; - - ### look in the paths for the files - foreach my $path (ref($paths) ? @$paths : $paths) { - $path =~ s|//+|/|g; - $path =~ s|/$||; - next if exists $CACHE{$path}; - if (-f $path) { - my $ext = ($path =~ /\.(\w+)$/) ? $1 : ''; - next if ! $EXT{$ext}; - $CACHE{$path} = $self->read($path); - } elsif (-d _) { - $CACHE{$path} = 1; - File::Find::find(sub { - return if exists $CACHE{$File::Find::name}; - return if $File::Find::name =~ m|/CVS/|; - return if ! -f; - my $ext = (/\.(\w+)$/) ? $1 : ''; - return if ! $EXT{$ext}; - $CACHE{$File::Find::name} = $self->read($File::Find::name); - }, "$path/"); + my $self = shift; + my $paths = shift || $self->paths; + + ### what extensions do we look for + my %EXT; + if ($self->{'handler'}) { + if (UNIVERSAL::isa($self->{'handler'},'HASH')) { + %EXT = %{ $self->{'handler'} }; + } } else { - $CACHE{$path} = 0; + %EXT = %EXT_READERS; + if (! $self->{'html_key'} && ! $HTML_KEY) { + delete $EXT{$_} foreach qw(html htm); + } } - } + return if ! keys %EXT; + + ### look in the paths for the files + foreach my $path (ref($paths) ? @$paths : $paths) { + $path =~ s|//+|/|g; + $path =~ s|/$||; + next if exists $CACHE{$path}; + if (-f $path) { + my $ext = ($path =~ /\.(\w+)$/) ? $1 : ''; + next if ! $EXT{$ext}; + $CACHE{$path} = $self->read($path); + } elsif (-d _) { + $CACHE{$path} = 1; + require File::Find; + File::Find::find(sub { + return if exists $CACHE{$File::Find::name}; + return if $File::Find::name =~ m|/CVS/|; + return if ! -f; + my $ext = (/\.(\w+)$/) ? $1 : ''; + return if ! $EXT{$ext}; + $CACHE{$File::Find::name} = $self->read($File::Find::name); + }, "$path/"); + } else { + $CACHE{$path} = 0; + } + } +} + +sub in_cache { + my ($self, $file) = (@_ == 2) ? @_ : (undef, shift()); + return exists($CACHE{$file}) || 0; } ###----------------------------------------------------------------### @@ -634,43 +639,53 @@ __END__ =head1 SYNOPSIS - my $cob = CGI::Ex::Conf->new; + use CGI::Ex::Conf qw(conf_read conf_write); + + my $hash = conf_read("/tmp/foo.yaml"); + + conf_write("/tmp/foo.yaml", {key1 => $val1, key2 => $val2}); + + + ### OOP interface + + my $cob = CGI::Ex::Conf->new; - my $full_path_to_file = "/tmp/foo.val"; # supports ini, sto, val, pl, xml - my $hash = $cob->read($file); + my $full_path_to_file = "/tmp/foo.val"; # supports ini, sto, val, pl, xml + my $hash = $cob->read($file); - local $cob->{default_ext} = 'conf'; # default anyway + local $cob->{default_ext} = 'conf'; # default anyway - my @paths = qw(/tmp, /home/pauls); - local $cob->{paths} = \@paths; - my $hash = $cob->read('My::NameSpace'); - # will look in /tmp/My/NameSpace.conf and /home/pauls/My/NameSpace.conf + my @paths = qw(/tmp, /home/pauls); + local $cob->{paths} = \@paths; + my $hash = $cob->read('My::NameSpace'); + # will look in /tmp/My/NameSpace.conf and /home/pauls/My/NameSpace.conf - my $hash = $cob->read('My::NameSpace', {paths => ['/tmp']}); - # will look in /tmp/My/NameSpace.conf + my $hash = $cob->read('My::NameSpace', {paths => ['/tmp']}); + # will look in /tmp/My/NameSpace.conf - local $cob->{directive} = 'MERGE'; - my $hash = $cob->read('FooSpace'); - # OR # - my $hash = $cob->read('FooSpace', {directive => 'MERGE'}); - # will return merged hashes from /tmp/FooSpace.conf and /home/pauls/FooSpace.conf - # immutable keys are preserved from originating files + local $cob->{directive} = 'MERGE'; + my $hash = $cob->read('FooSpace'); + # OR # + my $hash = $cob->read('FooSpace', {directive => 'MERGE'}); + # will return merged hashes from /tmp/FooSpace.conf and /home/pauls/FooSpace.conf + # immutable keys are preserved from originating files - local $cob->{directive} = 'FIRST'; - my $hash = $cob->read('FooSpace'); - # will return values from first found file in the path. + local $cob->{directive} = 'FIRST'; + my $hash = $cob->read('FooSpace'); + # will return values from first found file in the path. - local $cob->{directive} = 'LAST'; # default behavior - my $hash = $cob->read('FooSpace'); - # will return values from last found file in the path. + local $cob->{directive} = 'LAST'; # default behavior + my $hash = $cob->read('FooSpace'); + # will return values from last found file in the path. - ### manipulate $hash - $cob->write('FooSpace'); # will write it out the changes + + ### manipulate $hash + $cob->write('FooSpace'); # will write it out the changes =head1 DESCRIPTION @@ -688,7 +703,7 @@ Oh - and it writes too. =over 4 -=item C<-Eread_ref> +=item C Takes a file and optional argument hashref. Figures out the type of handler to use to read the file, reads it and returns the ref. @@ -696,7 +711,7 @@ If you don't need the extended merge functionality, or key fallback, or immutable keys, or path lookup ability - then use this method. Otherwise - use ->read. -=item C<-Eread> +=item C First argument may be either a perl data structure, yaml string, a full filename, or a file "namespace". @@ -754,13 +769,13 @@ The immutable defaults may be overriden using $IMMUTABLE_QR and $IMMUTABLE_KEY. Errors during read die. If the file does not exist undef is returned. -=item C<-Ewrite_ref> +=item C Takes a file and the reference to be written. Figures out the type of handler to use to write the file and writes it. If you used the ->read_ref use this method. Otherwise, use ->write. -=item C<-Ewrite> +=item C Allows for writing back out the information read in by ->read. If multiple paths where used - the directive 'FIRST' will write the changes to the first @@ -769,7 +784,7 @@ immutable keys, then those keys are removed before writing. Errors during write die. -=item C<-Epreload_files> +=item C Arguments are file(s) and/or directory(s) to preload. preload_files will loop through the arguments, find the files that exist, read them in using @@ -778,6 +793,36 @@ in %CACHE. Directories are spidered for file extensions which match those listed in %EXT_READERS. This is useful for a server environment where CPU may be more precious than memory. +=item C + +Allow for testing if a particular filename is registered in the %CACHE - typically +from a preload_files call. This is useful when building wrappers around the +conf_read and conf_write method calls. + +=back + +=head1 FUNCTIONS + +=over4 + +=item conf_read + +Takes a filename. Returns the read contents of that filename. The handler +to use is based upon the extention on the file. + + my $hash = conf_read('/tmp/foo.yaml'); + + my $hash = conf_read('/tmp/foo', {file_type => 'yaml'}); + +Takes a filename and a data structure. Writes the data to the filename. The handler +to use is based upon the extention on the file. + + conf_write('/tmp/foo.yaml', \%hash); + + conf_write('/tmp/foo', \%hash, {file_type => 'yaml'}); + +=back + =head1 FILETYPES CGI::Ex::Conf supports the files found in %EXT_READERS by default. diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm index a841e8e..c4d49f9 100644 --- a/lib/CGI/Ex/Dump.pm +++ b/lib/CGI/Ex/Dump.pm @@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION use strict; use Exporter; -$VERSION = '2.03'; +$VERSION = '2.04'; @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); @@ -76,9 +76,13 @@ sub _what_is_this { ### dump it out my @dump = map {&$SUB($_)} @_; my @var = ('$VAR') x ($#dump + 1); - if ($line =~ s/^ .*\b \Q$called\E ( \(?\s* | \s+ )//x - && $line =~ s/(?:\s+if\s+.+)? ;? \s*$//x) { - $line =~ s/ \s*\) $ //x if $1 && $1 =~ /\(/; + my $hold; + if ($line =~ s/^ .*\b \Q$called\E ( \s* \( \s* | \s+ )//x + && ($hold = $1) + && ( $line =~ s/ \s* \b if \b .* \n? $ //x + || $line =~ s/ \s* ; \s* $ //x + || $line =~ s/ \s+ $ //x)) { + $line =~ s/ \s*\) $ //x if $hold =~ /^\s*\(/; my @_var = map {/^[\"\']/ ? 'String' : $_} split (/\s*,\s*/, $line); @var = @_var if $#var == $#_var; } diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm index 0947028..191f392 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.03'; + $VERSION = '2.04'; @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 new file mode 100644 index 0000000..fe7c562 --- /dev/null +++ b/lib/CGI/Ex/JSONDump.pm @@ -0,0 +1,358 @@ +package CGI::Ex::JSONDump; + +=head1 NAME + +CGI::Ex::JSONDump - Comprehensive data to JSON dump. + +=cut + +###----------------------------------------------------------------### +# Copyright 2006 - Paul Seamons # +# Distributed under the Perl Artistic License without warranty # +###----------------------------------------------------------------### + +use vars qw($VERSION + @EXPORT @EXPORT_OK); +use strict; +use base qw(Exporter); + +BEGIN { + $VERSION = '2.04'; + + @EXPORT = qw(JSONDump); + @EXPORT_OK = @EXPORT; + +}; + +sub JSONDump { + my ($data, $args) = @_; + return __PACKAGE__->new($args)->dump($data); +} + +###----------------------------------------------------------------### + +sub new { + my $class = shift || __PACKAGE__; + my $args = shift || {}; + my $self = bless {%$args}, $class; + + $self->{'skip_keys'} = {map {$_ => 1} ref($self->{'skip_keys'}) eq 'ARRAY' ? @{ $self->{'skip_keys'} } : $self->{'skip_keys'}} + if $self->{'skip_keys'} && ref $self->{'skip_keys'} ne 'HASH'; + + $self->{'sort_keys'} = 1 if ! exists $self->{'sort_keys'}; + + return $self; +} + +sub dump { + my ($self, $data, $args) = @_; + $self = $self->new($args) if ! ref $self; + + local $self->{'indent'} = ! $self->{'pretty'} ? '' : defined($self->{'indent'}) ? $self->{'indent'} : ' '; + local $self->{'hash_sep'} = ! $self->{'pretty'} ? ':' : defined($self->{'hash_sep'}) ? $self->{'hash_sep'} : ' : '; + local $self->{'hash_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'hash_nl'}) ? $self->{'hash_nl'} : "\n"; + local $self->{'array_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'array_nl'}) ? $self->{'array_nl'} : "\n"; + local $self->{'str_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'str_nl'}) ? $self->{'str_nl'} : "\n"; + + return $self->_dump($data, ''); +} + +sub _dump { + my ($self, $data, $prefix) = @_; + my $ref = ref $data; + + if ($ref eq 'CODE' && $self->{'play_coderefs'}) { + $data = $data->(); + $ref = ref $data; + } + + if ($ref eq 'HASH') { + my @keys = (grep { my $r = ref $data->{$_}; + ! $r || $self->{'handle_unknown_types'} || $r eq 'HASH' || $r eq 'ARRAY' || ($r eq 'CODE' && $self->{'play_coderefs'})} + grep { ! $self->{'skip_keys'} || ! $self->{'skip_keys'}->{$_} } + grep { ! $self->{'skip_keys_qr'} || $_ !~ $self->{'skip_keys_qr'} } + ($self->{'sort_keys'} ? (sort keys %$data) : (keys %$data))); + return "{}" if ! @keys; + return "{$self->{hash_nl}${prefix}$self->{indent}" + . join(",$self->{hash_nl}${prefix}$self->{indent}", + map { $self->js_escape($_, "${prefix}$self->{indent}") + . $self->{'hash_sep'} + . $self->_dump($data->{$_}, "${prefix}$self->{indent}") } + @keys) + . "$self->{hash_nl}${prefix}}"; + + } elsif ($ref eq 'ARRAY') { + return "[]" if ! @$data; + return "[$self->{array_nl}${prefix}$self->{indent}" + . join(",$self->{array_nl}${prefix}$self->{indent}", + map { $self->_dump($_, "${prefix}$self->{indent}") } + @$data) + . "$self->{array_nl}${prefix}]"; + + } elsif ($ref) { + return $self->{'handle_unknown_types'}->($self, $data, $ref) if ref($self->{'handle_unknown_types'}) eq 'CODE'; + return '"'.$data.'"'; ### don't do anything + + } else { + return $self->js_escape($data, "${prefix}$self->{indent}"); + } +} + +sub js_escape { + my ($self, $str, $prefix) = @_; + return 'null' if ! defined $str; + + ### allow things that look like numbers to show up as numbers (and those that aren't quite to not) + return $str if $str =~ /^ -? (?: \d{0,13} \. \d* [1-9] | \d{1,13}) $/x; + + my $quote = $self->{'single_quote'} ? "'" : '"'; + + $str =~ s/\\/\\\\/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 + $str =~ s/([\x00-\x07\x0b\x0e-\x1f])/'\\u00' . unpack('H2',$1)/eg; # from JSON::Converter + utf8::decode($str) if $self->{'utf8'} && &utf8::decode; + + ### escape and tags in the text + $str =~ s{({'str_nl'} && length($str) > 80) { + if ($self->{'single_quote'}) { + $str =~ s/\'\s*\+\'$// if $str =~ s/\n/\\n\'$self->{str_nl}${prefix}+\'/g; + } else { + $str =~ s/\"\s*\+\"$// if $str =~ s/\n/\\n\"$self->{str_nl}${prefix}+\"/g; + } + } else { + $str =~ s/\n/\\n/g; + } + + return $quote . $str . $quote; +} + +1; + +__END__ + +=head1 SYNOPSIS + + use CGI::Ex::JSONDump; + + my $js = JSONDump(\%complex_data, {pretty => 0}); + + ### OR + + my $js = CGI::Ex::JSONDump->new({pretty => 0})->dump(\%complex_data); + +=head1 DESCRIPTION + +CGI::Ex::JSONDump is a very lightweight and fast perl data structure to javascript object +notation dumper. This is useful for AJAX style methods, or dynamic page creation that +needs to embed perl data in the presented page. + +CGI::Ex::JSONDump has roughly the same output as JSON::objToJson, but with the following +differences: + + - CGI::Ex::JSONDump is much much lighter and smaller (a whopping 134 lines). + - It dumps Javascript in more browser friendly format (handling of tags). + - It removes unknown key types by default instead of dying. + - It allows for a general handler to handle unknown key types. + - It allows for fine grain control of all whitespace. + - It allows for skipping keys by name or by regex. + - It dumps both data structures and scalar types. + +=head1 METHODS + +=over 4 + +=item new + +Create a CGI::Ex::JSONDump object. Takes arguments hashref as single argument. + + my $obj = CGI::Ex::JSONDump->new(\%args); + +See the arguments section for a list of the possible arguments. + +=item dump + +Takes a perl data structure or scalar string or number and returns a string +containing the javascript representation of that string (in Javascript object +notation - JSON). + +=item js_escape + +Takes a scalar string or number and returns a javascript escaped string that will +embed properly in javascript. All numbers and strings of nested data structures +are passed through this method. + +=back + +=head1 FUNCTIONS + +=over 4 + +=item JSONDump + +A wrapper around the new and dump methods. Takes a structure to dump +and optional args to pass to the new routine. + + JSONDump($data, $args); + +Is the same as: + + CGI::Ex::JSONDump->new($args)->dump($data); + +=back + +=head1 ARGUMENTS + +The following arguments may be passed to the new method or as the second +argument to the JSONDump function. + +=over 4 + +=item pretty + +0 or 1. Default 0 (false). If true then dumped structures will +include whitespace to make them more readable. + + JSONDump({a => [1, 2]}, {pretty => 0}); + JSONDump({a => [1, 2]}, {pretty => 1}); + + Would print + + {"a":[1,2]} + { + "a" : [ + 1, + 2, + ] + } + +=item single_quote + +0 or 1. Default 0 (false). If true then escaped values will be quoted +with single quotes. Otherwise values are quoted with double quotes. + + JSONDump("a", {single_quote => 0}); + JSONDump('a', {single_quote => 0}); + + Would print + + "a" + 'a' + +=item sort_keys + +0 or 1. Default 1 (true) + +If true, then key/value pairs of hashrefs will be sorted will be output in sorted order. + +=item play_coderefs + +0 or 1. Default 0 (false). If true, then any code refs will be executed +and the returned string will be dumped. + +If false, then keys of hashrefs that contain coderefs will be skipped (unless +the handle_unknown_types property is set). Coderefs +that are in arrayrefs will show up as "CODE(0x814c648)" unless +the handle_unknown_types property is set. + +=item handle_unknown_types + +Default undef. If true it should contain a coderef that will be called if any +unknown types are encountered. The only default known types are scalar string +or number values, unblessed HASH refs and ARRAY refs (and CODE refs if the +play_coderefs property is set). All other types will be passed to the +handle_unknown_types method call. + + JSONDump({a => bless({}, 'A'), b => 1}, { + handle_unknown_types => sub { + my $self = shift; # a JSON object + my $data = shift; # the object to dump + + return $self->js_escape("Ref=" . ref $data); + }, + pretty => 0, + }); + + Would print + + {"a":"Ref=A","b":1} + +If the handle_unknown_types method is not set then keys hashrefs that have values +with unknown types will not be included in the javascript output. + + JSONDump({a => bless({}, 'A'), b => 1}, {pretty => 0}); + + Would print + + {"b":1} + +=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. + + JSONDump({a => 1, b => 1}, {skip_keys => ['a'], pretty => 0}); + + Would print + + {"b":1} + +=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. + + JSONDump({a => 1, _b => 1}, {skip_keys_qr => qr/^_/, pretty => 0}); + + Would print + + {"a":1} + +=item indent + +The level to indent each nested data structure level if pretty is true. Default is " ". + +=item hash_nl + +The whitespace to add after each hashref key/value pair if pretty is true. Default is "\n". + +=item hash_sep + +The separator and whitespace to put between each hashref key/value pair if pretty is true. Default is " : ". + +=item array_nl + +The whitespace to add after each arrayref entry if pretty is true. Default is "\n". + +=item str_nl + +The whitespace to add in between newline separated strings if pretty is true or the output line is +greater than 80 characters. Default is "\n". + + JSONDump("This is a long string\n" + ."with plenty of embedded newlines\n" + ."and is greater than 80 characters.\n", {pretty => 1, str_nl => "\n"}); + + Would print + + "This is a long string\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 +string will be contained on a single line. + +=back + +=head1 AUTHORS + +Paul Seamons + +=cut diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 75886ef..6c95025 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -39,7 +39,7 @@ use vars qw($VERSION ); BEGIN { - $VERSION = '2.03'; + $VERSION = '2.04'; $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception'; $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator'; diff --git a/lib/CGI/Ex/Template.pod b/lib/CGI/Ex/Template.pod index cd7dd09..83545c4 100644 --- a/lib/CGI/Ex/Template.pod +++ b/lib/CGI/Ex/Template.pod @@ -399,13 +399,8 @@ CET has its own built in recursive grammar system. =item There are no references. -There was in initial beta tests, but it was decided to remove the little used feature. - -It makes it the same as - - [% obj.method("foo") %] - -This is removed in CET. +There were in initial beta tests, but it was decided to remove the little used feature which +took a length of code to implement. =item The DEBUG directive is more limited. @@ -416,7 +411,8 @@ are on rather than a general line range. =item There is no ANYCASE configuration item. -There was in initial beta tests, but it was dropped in favor of consistent parsing syntax. +There was in initial beta tests, but it was dropped in favor of consistent parsing syntax (and +a minimal amount of speedup). =item There is no V1DOLLAR configuration item. @@ -751,7 +747,8 @@ object (except for true filters such as eval and redirect). =item '0' - [% item = 'foo' %][% item.0 %] Returns self. Allows for scalars to mask as arrays. + [% 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 @@ -797,7 +794,8 @@ This is a filter and is not available via the Text virtual object. =item format - [% item.format('%d') %] Print the string out in the specified format. Each line is + [% item.format('%d') %] Print the string out in the specified format. It is similar to + the "as" virtual method, except that the item is split on newline and each line is processed separately. =item hash @@ -847,7 +845,7 @@ Note: This filter is not available as of TT2.15. =item remove - [% item.remove("\s+") %] Same as remove - but is global and replaces with nothing. + [% item.remove("\s+") %] Same as replace - but is global and replaces with nothing. =item redirect @@ -868,13 +866,13 @@ This is a filter and is not available via the Text virtual object. [% item.replace("\s+", " ") %] Globally replace all space with   - [% item.replace("foo", "bar", 0) Replace only the first instance of foo with bar. + [% item.replace("foo", "bar", 0) %] Replace only the first instance of foo with bar. [% item.replace("(\w+)", "($1)") %] Surround all words with parenthesis. =item search - [% item.search("(\w+)" %] Tests if the given pattern is in the string. + [% item.search("(\w+)") %] Tests if the given pattern is in the string. =item size @@ -2195,7 +2193,7 @@ Collapse adjacent whitespace to a single space. The "=" is used to indicate CHO Hello. - [%- "Hi." -%] + [%= "Hi." =%] Howdy. @@ -2209,7 +2207,7 @@ Remove all adjacent whitespace. The "~" is used to indicate CHOMP_GREEDY. Hello. - [%- "Hi." -%] + [%~ "Hi." ~%] Howdy. @@ -2350,9 +2348,9 @@ Allow for passing in TT style filters. my $str = q{ [% a = "Hello" %] - 1([% a | filter1 %]) - 2([% a | filter2 %]) - 3([% a | filter3 %]) + 1 ([% a | filter1 %]) + 2 ([% a | filter2 %]) + 3 ([% a | filter3 %]) }; my $obj = CGI::Ex::Template->new(FILTERS => $filters); @@ -2360,9 +2358,9 @@ Allow for passing in TT style filters. Would print: - (11111) - (22222) - (33333) + 1 (11111) + 2 (22222) + 3 (33333) Filters passed in as an arrayref should contain a coderef and a value indicating if they are dynamic or static (true meaning dynamic). The diff --git a/lib/CGI/Ex/Validate.pm b/lib/CGI/Ex/Validate.pm index 2749642..16591d5 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.03'; +$VERSION = '2.04'; $DEFAULT_EXT = 'val'; $QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/; @@ -126,6 +126,7 @@ sub validate { next if $found{$field}; my $field_val = $group_val->{$field}; die "Found a nonhashref value on field $field" if ! UNIVERSAL::isa($field_val, 'HASH'); + $field_val->{'field'} = $field if ! defined $field_val->{'field'}; push @$fields, $field_val; } @@ -795,7 +796,16 @@ sub generate_js { "$js_uri_path/CGI/Ex/validate.js"; }; - if (eval { require JSON }) { + if (! $self->{'no_jsondump'} && eval { require CGI::Ex::JSONDump }) { + my $json = CGI::Ex::JSONDump->new({pretty => 1})->dump($val_hash); + return qq{ + +}; + + } elsif (! $self->{'no_json'} && eval { require JSON }) { my $json = JSON->new(pretty => 1)->objToJson($val_hash); return qq{ diff --git a/lib/CGI/Ex/validate.js b/lib/CGI/Ex/validate.js index a3b98eb..d8a6270 100644 --- a/lib/CGI/Ex/validate.js +++ b/lib/CGI/Ex/validate.js @@ -4,7 +4,7 @@ * Based upon CGI/Ex/Validate.pm v1.14 from Perl * * For instructions on usage, see perldoc of CGI::Ex::Validate * ***----------------------------------------------------------------**/ -// $Revision: 1.35 $ +// $Revision: 1.36 $ function Validate () { this.error = vob_error; @@ -292,7 +292,8 @@ function vob_validate_buddy (form, field, field_val, N_level, ifs_match) { for (var i = 0; i < tests.length; i ++) { var el = form[field]; var type = el.type; - if (type && (type == 'hidden' || type == 'password' || type == 'text' || type == 'textarea' || type == 'submit')) el.value = values[0] = field_val[tests[i]]; + if (type && (type == 'hidden' || type == 'password' || type == 'text' || type == 'textarea' || type == 'submit')) + el.value = values[0] = '' + field_val[tests[i]]; } } diff --git a/samples/app/cgi_ex_1.cgi b/samples/app/cgi_ex_1.cgi new file mode 100755 index 0000000..16ce4ba --- /dev/null +++ b/samples/app/cgi_ex_1.cgi @@ -0,0 +1,183 @@ +#!/usr/bin/perl -w + +=head1 NAME + +cgi_ex_1.cgi - Show a basic example using some of the CGI::Ex tools (but not App based) + +=cut + +if (__FILE__ eq $0) { + main(); +} + +###----------------------------------------------------------------### + +use strict; +use CGI::Ex; +use CGI::Ex::Validate (); +use CGI::Ex::Dump qw(debug); + +###----------------------------------------------------------------### + +sub main { + my $cgix = CGI::Ex->new; + my $vob = CGI::Ex::Validate->new; + my $form = $cgix->get_form(); + + ### allow for js validation libraries + ### path_info should contain something like /CGI/Ex/yaml_load.js + ### see the line with 'js_val' below + my $info = $ENV{PATH_INFO} || ''; + if ($info =~ m|^(/\w+)+.js$|) { + $info =~ s|^/+||; + $cgix->print_js($info); + return; + } + + + ### check for errors - if they have submitted information + my $has_info = ($form->{'processing'}) ? 1 : 0; + my $errob = $has_info ? $vob->validate($form, validation_hash()) : undef; + my $form_name = 'formfoo'; + + ### failed validation - send out the template + if (! $has_info || $errob) { + + ### get a template and swap defaults + my $swap = defaults_hash(); + + ### add errors to the swap (if any) + if ($errob) { + my $hash = $errob->as_hash(); + $swap->{$_} = delete($hash->{$_}) foreach keys %$hash; + $swap->{'error_header'} = 'Please correct the form information below'; + } + + ### get js validation ready + $swap->{'form_name'} = $form_name; + $swap->{'js_val'} = $vob->generate_js(validation_hash(), # filename or valhash + $form_name, # name of form + $ENV{'SCRIPT_NAME'}); # browser path to cgi that calls print_js + + ### swap in defaults, errors and js_validation + my $content = $cgix->swap_template(get_content_form(), $swap); + + ### fill form fields + $cgix->fill(\$content, $form); + #debug $content; + + ### print it out + $cgix->print_content_type(); + print $content; + return; + } + + debug $form; + + ### show some sort of success if there were no errors + $cgix->print_content_type; + my $content = $cgix->swap_template(get_content_success(), defaults_hash()); + print $content; + return; + +} + +###----------------------------------------------------------------### + +sub validation_hash { + return { + 'group order' => ['username', 'password', 'password_verify'], + username => { + required => 1, + min_len => 3, + max_len => 30, + match => 'm/^\w+$/', + # could probably all be done with match => 'm/^\w{3,30}$/' + }, + password => { + required => 1, + max_len => 20, + }, + password_verify => { + validate_if => 'password', + equals => 'password', + }, + }; +} + +sub defaults_hash { + return { + title => 'My Application', + script_name => $ENV{'SCRIPT_NAME'}, + color => ['#ccccff', '#aaaaff'], + } +} + +###----------------------------------------------------------------### + +sub get_content_form { + return qq{ + + + [% title %] + + + +

Please Enter information

+ [% error_header %] +
+ +
+ + +
+ + + + + + + + + + + + + + + + +
Username: + + [% username_error %]
Password: + [% password_error %]
Password Verify: + [% password_verify_error %]
+ + + + [% js_val %] + + + }; +} + +sub get_content_success { + return qq{ + + [% title %] + +

Success

+
+ print "I can now continue on with the rest of my script!"; + + + }; +} + +__END__ diff --git a/samples/app/cgi_ex_2.cgi b/samples/app/cgi_ex_2.cgi new file mode 100755 index 0000000..73f6e81 --- /dev/null +++ b/samples/app/cgi_ex_2.cgi @@ -0,0 +1,144 @@ +#!/usr/bin/perl -w + +=head1 NAME + +cgi_ex_2.cgi - Rewrite of cgi_ex_1.cgi using CGI::Ex::App + +=cut + +use strict; +use base qw(CGI::Ex::App); +use CGI::Ex::Dump qw(debug); + +if ($0 eq __FILE__) { + __PACKAGE__->navigate; +} + +### show what hooks ran when we are done +sub post_navigate { debug shift->dump_history } + +### this will work for both userinfo_hash_common and _success_hash_common +sub hash_common { + return { + title => 'My Application', + color => ['#ccccff', '#aaaaff'], + }; +} + +###----------------------------------------------------------------### + +sub main_hash_validation { + return { + 'group order' => ['username', 'password'], + username => { + required => 1, + min_len => 3, + max_len => 30, + match => 'm/^\w+$/', + # could probably all be done with match => 'm/^\w{3,30}$/' + }, + password => { + required => 1, + max_len => 20, + }, + password_verify => { + validate_if => 'password', + equals => 'password', + }, + }; +} + +sub main_finalize { + my $self = shift; + my $form = $self->form; + debug $form; + return 1; +} + +sub main_next_step { '_success' } + +sub main_file_print { + return \ qq { + + + [% title %] + + + +

Please Enter information

+ [% error_header %] +
+ +
+ + + + + + + + + + + + + + + + + + + +
Username: + + [% username_error %]
Password: + [% password_error %]
Password Verify: + [% password_verify_error %]
+ +
+ + [% js_validation %] + + +}; +} + +###----------------------------------------------------------------### + +sub _success_file_print { + return \ qq{ + + [% title %] + +

Success

+
+ print "I can now continue on with the rest of my script!"; + + +}; +} + +###----------------------------------------------------------------### +### These methods override the base functionality of CGI::Ex::App + +sub ready_validate { shift->form->{'processing'} ? 1 : 0 } + +sub set_ready_validate { + my $self = shift; + my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift); + if ($is_ready) { + $self->form->{'processing'} = 1; + } else { + delete $self->form->{'processing'}; + } +} + + +__END__ + diff --git a/samples/benchmark/bench_jsondump.pl b/samples/benchmark/bench_jsondump.pl new file mode 100755 index 0000000..38c1594 --- /dev/null +++ b/samples/benchmark/bench_jsondump.pl @@ -0,0 +1,88 @@ +#!/usr/bin/perl -w + +# Benchmark: running cejd, json, zejd for at least 2 CPU seconds... +# cejd: 4 wallclock secs ( 2.18 usr + 0.00 sys = 2.18 CPU) @ 7045.87/s (n=15360) +# json: 3 wallclock secs ( 2.16 usr + 0.00 sys = 2.16 CPU) @ 6634.26/s (n=14330) +# zejd: 3 wallclock secs ( 2.16 usr + 0.00 sys = 2.16 CPU) @ 6634.26/s (n=14330) +# Rate zejd json cejd +# zejd 6634/s -- 0% -6% +# json 6634/s 0% -- -6% +# cejd 7046/s 6% 6% -- +# +# Benchmark: running cejd, json for at least 2 CPU seconds... +# cejd: 3 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 5690.20/s (n=11608) +# json: 2 wallclock secs ( 2.06 usr + 0.00 sys = 2.06 CPU) @ 5291.75/s (n=10901) +# Rate json cejd +# json 5292/s -- -7% +# cejd 5690/s 8% -- +# +# Benchmark: running cejd, json for at least 2 CPU seconds... +# cejd: 4 wallclock secs ( 2.21 usr + 0.00 sys = 2.21 CPU) @ 24320.81/s (n=53749) +# json: 3 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 10048.13/s (n=21503) +# Rate json cejd +# json 10048/s -- -59% +# cejd 24321/s 142% -- + +use strict; + +use Benchmark qw(cmpthese timethese); +use JSON; +use CGI::Ex::JSONDump; + +my $json = JSON->new(pretty => 0, keysort => 0); +my $cejd = CGI::Ex::JSONDump->new({pretty => 0, no_sort => 1}); + + +my $data = { + one => 'two', + three => [qw(a b c)], + four => 1, + five => '1.0', + six => undef, +}; + +print "JSON\n--------------------\n". $json->objToJson($data)."\n----------------------------\n"; +print "CEJD\n--------------------\n". $cejd->dump($data) ."\n----------------------------\n"; + +cmpthese timethese(-2, { + json => sub { my $a = $json->objToJson($data) }, + cejd => sub { my $a = $cejd->dump($data) }, + zejd => sub { my $a = $cejd->dump($data) }, +}); + +###----------------------------------------------------------------### + +$json = JSON->new(pretty => 1, keysort => 1); +$cejd = CGI::Ex::JSONDump->new({pretty => 1}); + +$data = { + one => 'two', + three => [qw(a b c)], + four => 1, + five => '1.0', + six => '12345678901234567890', + seven => undef, +}; + +print "JSON\n--------------------\n". $json->objToJson($data)."\n----------------------------\n"; +print "CEJD\n--------------------\n". $cejd->dump($data) ."\n----------------------------\n"; + +cmpthese timethese(-2, { + json => sub { my $a = $json->objToJson($data) }, + cejd => sub { my $a = $cejd->dump($data) }, +}); + +###----------------------------------------------------------------### + +$json = JSON->new(pretty => 1); +$cejd = CGI::Ex::JSONDump->new({pretty => 1}); + +$data = ["foo\n"]; + +print "JSON\n--------------------\n". $json->objToJson($data)."\n----------------------------\n"; +print "CEJD\n--------------------\n". $cejd->dump($data) ."\n----------------------------\n"; + +cmpthese timethese(-2, { + json => sub { my $a = $json->objToJson($data) }, + cejd => sub { my $a = $cejd->dump($data) }, +}); diff --git a/samples/benchmark/bench_template.pl b/samples/benchmark/bench_template.pl index 450078b..7b48028 100644 --- a/samples/benchmark/bench_template.pl +++ b/samples/benchmark/bench_template.pl @@ -83,6 +83,27 @@ my $longer_template = "[% INCLUDE bar.tt %]" ."[% array.join('|') %]" ."[% PROCESS bar.tt %]"; +my $hello2000 = "[% title %] +[% array = [ \"Hello\", \"World\", \"2000\", \"Hello\", \"World\", \"2000\" ] %] +[% sorted = array.sort %] +[% multi = [ sorted, sorted, sorted, sorted, sorted ] %] + +[% FOREACH row = multi %] + + [% FOREACH col = row %] + + [% END %] + +[% END %] +
[% col %]
+[% param = integer %] +[% FOREACH i = [ 1 .. 10 ] %] + [% var = i + param %]" + .("\n [%var%] Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
"x20)." +[% END %] + +"; + ###----------------------------------------------------------------### ### set a few globals that will be available in our subs my $show_list = grep {$_ eq '--list'} @ARGV; @@ -146,7 +167,8 @@ my $tests = { # '43_filteruri' => "[% ' ' | uri %]", # 132% # 550% # 379% # 471% # 12524.4/s # '44_filterevl' => "[% foo | eval %]", # 303% # 530% # 434% # 478% # 5475.5/s # '45_capture' => "[% foo = BLOCK %]Hi[% END %][% foo %]", # 102% # 386% # 291% # 304% # 10606.5/s # - '46_complex' => "$longer_template", # 55% # 288% # 133% # 251% # 1230.3/s # + '46_complex' => "$longer_template", # 60% # 290% # 160% # 270% # 1054.3/s # + '47_hello2000' => "$hello2000", # 2% # 136% # 39% # 115% # 184.8/s # # overall # 95% # 406% # 251% # 346% # diff --git a/samples/index.cgi b/samples/index.cgi new file mode 100755 index 0000000..eb9a399 --- /dev/null +++ b/samples/index.cgi @@ -0,0 +1,105 @@ +#!/usr/bin/perl -w + +=head1 NAME + +index.cgi - Show a listing of available utilties in the samples directories. + +=cut + +use strict; +use base qw(CGI::Ex::App); +use FindBin qw($Bin); + +__PACKAGE__->navigate; + +sub main_file_print { + return \ q{ +CGI::Ex Samples + +

CGI::Ex Samples

+Looking at directory: [% base %]
+All of the samples in this directory should be ready to run. To +enable this directory you should use something similar to the following in your apache conf file: +
+ScriptAlias /samples/ /home/pauls/perl/CGI-Ex/samples/
+<Location /samples/>
+    SetHandler perl-script
+    PerlResponseHandler ModPerl::PerlRun
+    Options +ExecCGI
+</Location>
+
+For mod_perl 1 you would use something similar to: +
+ScriptAlias /samples/ /home/pauls/perl/CGI-Ex/samples/
+<Location /samples/>
+    SetHandler perl-script
+    PerlHandler Apache::PerlRun
+    Options +ExecCGI
+</Location>
+
+ +

Application examples

+[% FOREACH file = app.keys.sort ~%] +[% script_dir ~ file %] - [% app.$file %]
+[% END -%] + +

Benchmark stuff

+[% FOREACH file = bench.keys.sort ~%] +[% file %] - [% bench.$file %]
+[% END -%] + +

Other files

+[% FOREACH file = therest.keys.sort ~%] +[% file %] - [% therest.$file %]
+[% END -%] + + + + }; +} + +sub main_hash_swap { + my $self = shift; + my $base = $self->base_dir_abs; + my $hash = {}; + my %file; + + require File::Find; + File::Find::find(sub { + return if ! -f; + return if $File::Find::name =~ / CVS | ~$ | ^\# /x; + $File::Find::name =~ /^\Q$base\E(.+)/ || return; + my $name = $1; + my $desc = ''; + if (open FH, "<$_") { + read FH, my $str, -s; + close FH; + if ($str =~ /^=head1 NAME\s+(.+)\s+^=cut\s+/m) { + $desc = $1; + $desc =~ s/^\w+(?:\.\w+)?\s+-\s+//; + } + } + $file{$name} = $desc; + }, $base); + + $hash->{'base'} = $base; + + $hash->{'script_dir'} = $ENV{'SCRIPT_NAME'} || $0; + $hash->{'script_dir'} =~ s|/[^/]+$||; + + $hash->{'app'} = {map {$_ => $file{$_}} grep {/app/ && /\.cgi$/} keys %file}; + + $hash->{'bench'} = {map {$_ => $file{$_}} grep {/bench/ && /\.pl$/} keys %file}; + + $hash->{'therest'} = {map {$_ => $file{$_}} grep {! exists $hash->{'bench'}->{$_} + && ! exists $hash->{'app'}->{$_}} keys %file}; + + return $hash; +} + +sub base_dir_abs { + my $dir = $0; + $dir =~ s|/[^/]+$||; + return $dir; +} + diff --git a/samples/memory_template.pl b/samples/memory_template.pl index 28b1710..6b03cdf 100644 --- a/samples/memory_template.pl +++ b/samples/memory_template.pl @@ -10,6 +10,7 @@ my $swap = { }; my $txt = "[% one %][% two %][% three %][% hash.keys.join %] [% code(one).length %] [% hash.\$a_var %]\n"; +#$txt = hello2000(); ###----------------------------------------------------------------### @@ -37,3 +38,26 @@ sleep 15; # go and check the 'ps fauwx|grep perl' ###----------------------------------------------------------------### + +sub hello2000 { + my $hello2000 = "[% title %] +[% array = [ \"Hello\", \"World\", \"2000\", \"Hello\", \"World\", \"2000\" ] %] +[% sorted = array.sort %] +[% multi = [ sorted, sorted, sorted, sorted, sorted ] %] + +[% FOREACH row = multi %] + + [% FOREACH col = row %] + + [% END %] + +[% END %] +
[% col %]
+[% param = integer %] +[% FOREACH i = [ 1 .. 10 ] %] + [% var = i + param %]" + .("\n [%var%] Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
"x20)." +[% END %] + +"; +} diff --git a/t/8_auth_00_base.t b/t/8_auth_00_base.t index c47492c..4b5cbfd 100644 --- a/t/8_auth_00_base.t +++ b/t/8_auth_00_base.t @@ -7,7 +7,7 @@ =cut use strict; -use Test::More tests => 33; +use Test::More tests => 35; use_ok('CGI::Ex::Auth'); @@ -33,7 +33,7 @@ use_ok('CGI::Ex::Auth'); use vars qw($crypt); BEGIN { $crypt = crypt('123qwe', 'SS') }; sub use_crypt { 1 } - sub get_pass_by_user { $crypt } + sub get_pass_by_user { {password => $crypt, foobar => 'baz'} } } my $token = Auth->new->generate_token({user => 'test', real_pass => '123qwe', use_base64 => 1}); @@ -97,6 +97,11 @@ ok(! $Auth::set_cookie, "Set_cookie was not called"); ok($Auth::deleted_cookie, "deleted_cookie was not called"); +my $auth = Aut2->get_valid_auth({form => {%$form_good3}}); +my $data = $auth->last_auth_data; +ok($auth && $data, "Aut2 worked again"); +ok($data->{'foobar'} eq 'baz', 'And it contained the correct value'); + SKIP: { skip("Crypt::Blowfish not found", 4) if ! eval { require Crypt::Blowfish }; diff --git a/t/9_jsondump_00_base.t b/t/9_jsondump_00_base.t new file mode 100644 index 0000000..a124a4f --- /dev/null +++ b/t/9_jsondump_00_base.t @@ -0,0 +1,109 @@ +# -*- Mode: Perl; -*- + +=head1 NAME + +9_jsondump_00_base.t - Testing of the CGI::Ex::JSONDump module. + +=cut + +use strict; +use Test::More tests => 49; + +use_ok('CGI::Ex::JSONDump'); + +ok(eval { CGI::Ex::JSONDump->import('JSONDump'); 1 }, "Import JSONDump"); + +ok(&JSONDump, "Got the sub"); + +my $obj = CGI::Ex::JSONDump->new; + +ok(JSONDump({a => 1}) eq $obj->dump({a => 1}), "Function and OO Match"); + +ok($obj->dump("foo") eq $obj->js_escape("foo"), "js_escape works"); + +sub test_dump { + my $data = shift; + my $str = shift; + my $args = shift || {}; + my ($sub, $file, $line) = caller; + + my $out = JSONDump($data, $args); + + if ($out eq $str) { + ok(1, "Dump matched at line $line"); + } else { + ok(0, "Didn't match at line $line - shouldv'e been" + ."\n---------------------\n" + . $str + ."\n---------------------\n" + ."Was" + ."\n---------------------\n" + . $out + ."\n---------------------\n" + ); + } +} + +###----------------------------------------------------------------### + +test_dump({a => 1}, "{\n \"a\" : 1\n}", {pretty => 1}); +test_dump({a => 1}, "{\"a\":1}", {pretty => 0}); + +test_dump([1, 2, 3], "[\n 1,\n 2,\n 3\n]", {pretty => 1}); +test_dump([1, 2, 3], "[1,2,3]", {pretty => 0}); + +test_dump({a => [1,2]}, "{\"a\":[1,2]}", {pretty => 0}); +test_dump({a => [1,2]}, "{\n \"a\" : [\n 1,\n 2\n ]\n}", {pretty => 1}); + +test_dump({a => sub {}}, "{}", {pretty => 0}); +test_dump({a => sub {}}, "{\"a\":\"CODE\"}", {handle_unknown_types => sub {my $self=shift;return $self->js_escape(ref shift)}, pretty => 0}); + +test_dump({a => 1}, "{}", {skip_keys => ['a']}); +test_dump({a => 1}, "{}", {skip_keys => {a=>1}}); + +test_dump({2 => 1, _a => 1}, "{2:1,\"_a\":1}", {pretty=>0}); +test_dump({2 => 1, _a => 1}, "{2:1}", {pretty=>0, skip_keys_qr => qr/^_/}); + +test_dump({a => 1}, "{\n \"a\" : 1\n}", {pretty => 1}); +test_dump({a => 1}, "{\n \"a\" : 1\n}", {pretty => 1, hash_nl => "\n", hash_sep => " : ", indent => " "}); +test_dump({a => 1}, "{\n\"a\" : 1\n}", {pretty => 1, hash_nl => "\n", hash_sep => " : ", indent => ""}); +test_dump({a => 1}, "{\"a\" : 1}", {pretty => 1, hash_nl => "", hash_sep => " : ", indent => ""}); +test_dump({a => 1}, "{\"a\":1}", {pretty => 1, hash_nl => "", hash_sep => ":", indent => ""}); +test_dump({a => 1}, "{\"a\":1}", {pretty => 0, hash_nl => "\n", hash_sep => " : "}); + +test_dump(['a' => 1], "[\n \"a\",\n 1\n]", {pretty => 1}); +test_dump(['a' => 1], "[\n \"a\",\n 1\n]", {pretty => 1, array_nl => "\n", indent => " "}); +test_dump(['a' => 1], "[\n\"a\",\n1\n]", {pretty => 1, array_nl => "\n", indent => ""}); +test_dump(['a' => 1], "[\"a\",1]", {pretty => 1, array_nl => "", indent => ""}); +test_dump(['a' => 1], "[\"a\",1]", {pretty => 0, array_nl => "\n"}); + + + +test_dump(1, "1"); +test_dump('1.0', '"1.0"'); +test_dump('123456789012345', '"123456789012345"'); +test_dump('a', '"a"'); +test_dump("\n", '"\\n"'); +test_dump("\\", '"\\\\"'); +test_dump('