+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.
-CGI-Ex.spec
Changes
lib/CGI/Ex.pm
lib/CGI/Ex/App.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
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
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
t/7_template_00_base.t
t/7_template_01_includes.t
t/8_auth_00_base.t
+t/9_jsondump_00_base.t
# 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:
use base qw(Exporter);
BEGIN {
- $VERSION = '2.03';
+ $VERSION = '2.04';
$PREFERRED_CGI_MODULE ||= 'CGI';
@EXPORT = ();
@EXPORT_OK = qw(get_form
use vars qw($VERSION);
BEGIN {
- $VERSION = '2.03';
+ $VERSION = '2.04';
Time::HiRes->import('time') if eval {require Time::HiRes};
}
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
use Digest::MD5 qw(md5_hex);
use CGI::Ex;
-$VERSION = '2.03';
+$VERSION = '2.04';
###----------------------------------------------------------------###
$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,
};
}
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) {
} 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;
<input type="hidden" name="[% key_expires_min %]" value="">
<table class="login_table">
<tr class="login_username">
- <td>Username:</td>
+ <td>[% text_user %]</td>
<td><input name="[% key_user %]" type="text" size="30" value=""></td>
</tr>
<tr class="login_password">
- <td>Password:</td>
+ <td>[% text_pass %]</td>
<td><input name="[% key_pass %]" type="password" size="30" value=""></td>
</tr>
<tr class="login_save">
<td colspan="2">
- <input type="checkbox" name="[% key_save %]" value="1"> Save Password ?
+ <input type="checkbox" name="[% key_save %]" value="1"> [% text_save %]
</td>
</tr>
<tr class="login_submit">
};
}
+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 %]
secure_hash_keys
template_args
template_include_path
+ text_user
+ text_pass
+ text_save
use_base64
use_blowfish
use_crypt
$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<key_logout>
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<cgix>
Returns a CGI::Ex object.
is capable of taking the login_fields and creating an md5 cram which prevents
the password from being passed plaintext.
+=item C<text_user, text_pass, text_save>
+
+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 <perlspam at seamons dot com>
+Paul Seamons <paul at seamons dot com>
=cut
$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';
###----------------------------------------------------------------###
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;
}
###----------------------------------------------------------------###
=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
=over 4
-=item C<-E<gt>read_ref>
+=item C<read_ref>
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.
or immutable keys, or path lookup ability - then use this method.
Otherwise - use ->read.
-=item C<-E<gt>read>
+=item C<read>
First argument may be either a perl data structure, yaml string, a
full filename, or a file "namespace".
Errors during read die. If the file does not exist undef is returned.
-=item C<-E<gt>write_ref>
+=item C<write_ref>
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<-E<gt>write>
+=item C<write>
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
Errors during write die.
-=item C<-E<gt>preload_files>
+=item C<preload_files>
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
listed in %EXT_READERS. This is useful for a server environment where CPU
may be more precious than memory.
+=item C<in_cache>
+
+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.
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);
### 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;
}
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);
};
--- /dev/null
+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 <html> and </html> tags in the text
+ $str =~ s{(</? (?: htm | scrip | !-))}{$1$quote+$quote}gx;
+
+ ### add nice newlines (unless pretty is off)
+ if ($self->{'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 </script> 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 <paul at seamons dot com>
+
+=cut
);
BEGIN {
- $VERSION = '2.03';
+ $VERSION = '2.04';
$PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
$PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
=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.
=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.
=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
=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
=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
[% 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
Hello.
- [%- "Hi." -%]
+ [%= "Hi." =%]
Howdy.
Hello.
- [%- "Hi." -%]
+ [%~ "Hi." ~%]
Howdy.
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);
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
@UNSUPPORTED_BROWSERS
);
-$VERSION = '2.03';
+$VERSION = '2.04';
$DEFAULT_EXT = 'val';
$QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;
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;
}
"$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{<script src="$js_uri_path_validate"></script>
+<script>
+document.validation = $json;
+if (document.check_form) document.check_form("$form_name");
+</script>
+};
+
+ } elsif (! $self->{'no_json'} && eval { require JSON }) {
my $json = JSON->new(pretty => 1)->objToJson($val_hash);
return qq{<script src="$js_uri_path_validate"></script>
* 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;
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]];
}
}
--- /dev/null
+#!/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{
+ <html>
+ <head>
+ <title>[% title %]</title>
+ <style>
+ .error {
+ display: block;
+ color: red;
+ font-weight: bold;
+ }
+ </style>
+ </head>
+ <body>
+ <h1 style='color:blue'>Please Enter information</h1>
+ <span style='color:red'>[% error_header %]</span>
+ <br>
+
+ <form name="[% form_name %]" action="[% script_name %]" method="POST">
+ <input type=hidden name=processing value=1>
+
+ <table>
+ <tr bgcolor=[% color.0 %]>
+ <td>Username:</td>
+ <td>
+ <input type=text size=30 name=username>
+ <span class=error id=username_error>[% username_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.1 %]>
+ <td>Password:</td>
+ <td><input type=password size=20 name=password>
+ <span class=error id=password_error>[% password_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.0 %]>
+ <td>Password Verify:</td>
+ <td><input type=password size=20 name=password_verify>
+ <span class=error id=password_verify_error>[% password_verify_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.1 %]>
+ <td colspan=2 align=right><input type=submit value=Submit></td>
+ </tr>
+
+ </table>
+
+ </form>
+
+ [% js_val %]
+ </body>
+ </html>
+ };
+}
+
+sub get_content_success {
+ return qq{
+ <html>
+ <head><title>[% title %]</title></head>
+ <body>
+ <h1 style='color:green'>Success</h1>
+ <br>
+ print "I can now continue on with the rest of my script!";
+ </body>
+ </html>
+ };
+}
+
+__END__
--- /dev/null
+#!/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 {
+ <html>
+ <head>
+ <title>[% title %]</title>
+ <style>
+ .error {
+ display: block;
+ color: red;
+ font-weight: bold;
+ }
+ </style>
+ </head>
+ <body>
+ <h1 style='color:blue'>Please Enter information</h1>
+ <span style='color:red'>[% error_header %]</span>
+ <br>
+
+ <form name="[% form_name %]" action="[% script_name %]" method="POST">
+ <input type=hidden name=processing value=1>
+
+ <table>
+ <tr bgcolor=[% color.0 %]>
+ <td>Username:</td>
+ <td>
+ <input type=text size=30 name=username>
+ <span class=error id=username_error>[% username_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.1 %]>
+ <td>Password:</td>
+ <td><input type=password size=20 name=password>
+ <span class=error id=password_error>[% password_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.0 %]>
+ <td>Password Verify:</td>
+ <td><input type=password size=20 name=password_verify>
+ <span class=error id=password_verify_error>[% password_verify_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.1 %]>
+ <td colspan=2 align=right><input type=submit value=Submit></td>
+ </tr>
+
+ </table>
+
+ </form>
+
+ [% js_validation %]
+ </body>
+ </html>
+};
+}
+
+###----------------------------------------------------------------###
+
+sub _success_file_print {
+ return \ qq{
+ <html>
+ <head><title>[% title %]</title></head>
+ <body>
+ <h1 style='color:green'>Success</h1>
+ <br>
+ print "I can now continue on with the rest of my script!";
+ </body>
+ </html>
+};
+}
+
+###----------------------------------------------------------------###
+### 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__
+
--- /dev/null
+#!/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<script>\nThis is sort of \"odd\"\n</script>"];
+
+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) },
+});
."[% array.join('|') %]"
."[% PROCESS bar.tt %]";
+my $hello2000 = "<html><head><title>[% title %]</title></head><body>
+[% array = [ \"Hello\", \"World\", \"2000\", \"Hello\", \"World\", \"2000\" ] %]
+[% sorted = array.sort %]
+[% multi = [ sorted, sorted, sorted, sorted, sorted ] %]
+<table>
+[% FOREACH row = multi %]
+ <tr bgcolor=\"[% loop.count % 2 ? 'gray' : 'white' %]\">
+ [% FOREACH col = row %]
+ <td align=\"center\"><font size=\"+1\">[% col %]</font></td>
+ [% END %]
+ </tr>
+[% END %]
+</table>
+[% 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 <br/>"x20)."
+[% END %]
+</body></html>
+";
+
###----------------------------------------------------------------###
### set a few globals that will be available in our subs
my $show_list = grep {$_ eq '--list'} @ARGV;
'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% #
--- /dev/null
+#!/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{<html>
+<head><title>CGI::Ex Samples</title></head>
+<body>
+<h1>CGI::Ex Samples</h1>
+Looking at directory: [% base %]<br>
+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:
+<pre>
+ScriptAlias /samples/ /home/pauls/perl/CGI-Ex/samples/
+<Location /samples/>
+ SetHandler perl-script
+ PerlResponseHandler ModPerl::PerlRun
+ Options +ExecCGI
+</Location>
+</pre>
+For mod_perl 1 you would use something similar to:
+<pre>
+ScriptAlias /samples/ /home/pauls/perl/CGI-Ex/samples/
+<Location /samples/>
+ SetHandler perl-script
+ PerlHandler Apache::PerlRun
+ Options +ExecCGI
+</Location>
+</pre>
+
+<h2>Application examples</h2>
+[% FOREACH file = app.keys.sort ~%]
+<a href="[% script_dir ~ file %]">[% script_dir ~ file %]</a> - [% app.$file %]<br>
+[% END -%]
+
+<h2>Benchmark stuff</h2>
+[% FOREACH file = bench.keys.sort ~%]
+[% file %] - [% bench.$file %]<br>
+[% END -%]
+
+<h2>Other files</h2>
+[% FOREACH file = therest.keys.sort ~%]
+[% file %] - [% therest.$file %]<br>
+[% END -%]
+
+</body>
+</html>
+ };
+}
+
+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;
+}
+
};
my $txt = "[% one %][% two %][% three %][% hash.keys.join %] [% code(one).length %] [% hash.\$a_var %]\n";
+#$txt = hello2000();
###----------------------------------------------------------------###
###----------------------------------------------------------------###
+
+sub hello2000 {
+ my $hello2000 = "<html><head><title>[% title %]</title></head><body>
+[% array = [ \"Hello\", \"World\", \"2000\", \"Hello\", \"World\", \"2000\" ] %]
+[% sorted = array.sort %]
+[% multi = [ sorted, sorted, sorted, sorted, sorted ] %]
+<table>
+[% FOREACH row = multi %]
+ <tr bgcolor=\"[% loop.count % 2 ? 'gray' : 'white' %]\">
+ [% FOREACH col = row %]
+ <td align=\"center\"><font size=\"+1\">[% col %]</font></td>
+ [% END %]
+ </tr>
+[% END %]
+</table>
+[% 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 <br/>"x20)."
+[% END %]
+</body></html>
+";
+}
=cut
use strict;
-use Test::More tests => 33;
+use Test::More tests => 35;
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});
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 };
--- /dev/null
+# -*- 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('<script>', '"<scrip"+"t>"');
+test_dump('<script>', "'<scrip'+'t>'", {single_quote => 1});
+test_dump('<html>', '"<htm"+"l>"');
+test_dump('<!--', '"<!-"+"-"');
+test_dump('"', '"\\""');
+test_dump('a', "'a'", {single_quote => 1});
+test_dump('"', "'\"'", {single_quote => 1});
+
+my $code = sub {};
+my $str = "\"$code\"";
+test_dump($code, $str);
+test_dump($code, "\"CODE\"", {handle_unknown_types => sub { my($self, $data)=@_; return '"'.ref($data).'"'}});
+
+
+test_dump(sub { "ab" }, '"ab"', {play_coderefs => 1});
+test_dump({a => sub { "ab" }}, '{"a":"ab"}', {pretty=>0,play_coderefs => 1});
+
+test_dump("Foo\n".("Bar"x30), "\"Foo\\n\"\n +\"".("Bar"x30)."\"", {pretty => 1});
+test_dump("Foo\n".("Bar"x30), "\"Foo\\n\"\n\n +\"".("Bar"x30)."\"", {pretty => 1, str_nl => "\n\n"});
+
+test_dump("Foo\n".("Bar"x30), "'Foo\\n'\n +'".("Bar"x30)."'", {pretty => 1, single_quote => 1});
+test_dump("Foo\n".("Bar"x30), "'Foo\\n'\n\n +'".("Bar"x30)."'", {pretty => 1, str_nl => "\n\n", single_quote => 1});
projects / chaz / p5-CGI-Ex / commitdiff
