+2.05 2006-07-19
+ * Allow for CGI::Ex to be compatible with Mandrake and Fedora mod_perl 2, as well as debian mod_perl2
+ and older mod_perl1.
+ * Allow for CGI::Ex::Dump to localize the Data::Dumper options to not stomp on anybody elses toes.
+ * Update various perldoc bugs
+ * Fix JSONDump of \t and \r
+ * Change .as to .fmt to coincide with Perl6 (.as is still there - just not documented)
+
2.04 2006-07-10
* Allow for items not in group order to get added to validation correctly in CGI::Ex::Validate.
* Add samples/index.cgi
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: CGI-Ex
-version: 2.04
+version: 2.05
version_from: lib/CGI/Ex.pm
installdirs: site
requires:
use base qw(Exporter);
BEGIN {
- $VERSION = '2.04';
+ $VERSION = '2.05';
$PREFERRED_CGI_MODULE ||= 'CGI';
@EXPORT = ();
@EXPORT_OK = qw(get_form
set_cookie
location_bounce
);
+
+ ### cache mod_perl version (light if or if not mod_perl)
+ my $v = (! $ENV{'MOD_PERL'}) ? 0
+ # mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1
+ # if MOD_PERL is set - don't die if regex fails - just assume 1.0
+ : ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x) ? $1
+ : '1.0_0';
+ sub _mod_perl_version () { $v }
+ sub _is_mod_perl_1 () { $v < 1.98 && $v > 0 }
+ sub _is_mod_perl_2 () { $v >= 1.98 }
+
+ ### cache apache request getter (light if or if not mod_perl)
+ my $sub;
+ if (_is_mod_perl_1) { # old mod_perl
+ require Apache;
+ $sub = sub { Apache->request };
+ } elsif (_is_mod_perl_2) {
+ if (eval { require Apache2::RequestRec }) { # debian style
+ require Apache2::RequestUtil;
+ $sub = sub { Apache2::RequestUtil->request };
+ } else { # fedora and mandrake style
+ require Apache::RequestUtil;
+ $sub = sub { Apache->request };
+ }
+ } else {
+ $sub = sub {};
+ }
+ sub apache_request_sub () { $sub }
}
###----------------------------------------------------------------###
my $self = shift || die 'Usage: $cgix_obj->apache_request';
$self->{'apache_request'} = shift if $#_ != -1;
- if (! $self->{'apache_request'}) {
- if ($self->is_mod_perl_1) {
- require Apache;
- $self->{'apache_request'} = Apache->request;
- } elsif ($self->is_mod_perl_2) {
- require Apache2::RequestRec;
- require Apache2::RequestUtil;
- $self->{'apache_request'} = Apache2::RequestUtil->request;
- }
- }
-
- return $self->{'apache_request'};
+ return $self->{'apache_request'} ||= apache_request_sub()->();
}
### Get the version of mod_perl running (0 if not mod_perl)
# my $version = $cgix->mod_perl_version;
-sub mod_perl_version {
- my $self = shift || die 'Usage: $cgix_obj->mod_perl_version';
-
- if (! defined $self->{'mod_perl_version'}) {
- return 0 if ! $ENV{'MOD_PERL'};
- # mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1
- # if MOD_PERL is set - don't die if regex fails - just assume 1.0
- $self->{'mod_perl_version'} = ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x)
- ? $1 : '1.0_0';
- }
- return $self->{'mod_perl_version'};
-}
-
-sub is_mod_perl_1 { my $m = shift->mod_perl_version; return $m < 1.98 && $m > 0 }
-sub is_mod_perl_2 { my $m = shift->mod_perl_version; return $m >= 1.98 }
+sub mod_perl_version { _mod_perl_version }
+sub is_mod_perl_1 { _is_mod_perl_1 }
+sub is_mod_perl_2 { _is_mod_perl_2 }
### Allow for a setter
# $cgix->set_apache_request($r)
use vars qw($VERSION);
BEGIN {
- $VERSION = '2.04';
+ $VERSION = '2.05';
Time::HiRes->import('time') if eval {require Time::HiRes};
}
use Digest::MD5 qw(md5_hex);
use CGI::Ex;
-$VERSION = '2.04';
+$VERSION = '2.05';
###----------------------------------------------------------------###
=head1 SYNOPSIS
- ### authorize the user
- my $auth = $self->get_valid_auth({
- get_pass_by_user => \&get_pass_by_user,
- });
+ use CGI::Ex::Auth;
+ ### authorize the user
+ my $auth = CGI::Ex::Auth->get_valid_auth({
+ get_pass_by_user => \&get_pass_by_user,
+ });
- sub get_pass_by_user {
- my $auth = shift;
- my $user = shift;
- my $pass = some_way_of_getting_password($user);
- return $pass;
- }
+
+ sub get_pass_by_user {
+ my $auth = shift;
+ my $user = shift;
+ my $pass = some_way_of_getting_password($user);
+ return $pass;
+ }
+
+ ### OR - if you are using a OO based CGI or Application
+
+ sub require_authentication {
+ my $self = shift;
+
+ return $self->{'auth'} = CGI::Ex::Auth->get_valid_auth({
+ get_pass_by_user => sub {
+ my ($auth, $user) = @_;
+ return $self->get_pass($user);
+ },
+ });
+ }
+
+ sub get_pass {
+ my ($self, $user) = @_;
+ return $self->loopup_and_cache_pass($user);
+ }
=head1 DESCRIPTION
get_pass_by_user => sub {
my ($auth_obj, $user) = @_;
- return $some_obj->get_pass({user => $user});
+ my $pass = $some_obj->get_pass({user => $user});
+ return $pass;
}
Alternately, get_pass_by_user may return a hashref of data items that
);
@EXPORT_OK = qw(conf_read conf_write in_cache);
-$VERSION = '2.04';
+$VERSION = '2.05';
$DEFAULT_EXT = 'conf';
Should be an xml file. It will be read in by XMLin. See L<XML::Simple>.
+=item C<json>
+
+Should be a json file. It will be read using the JSON library. See L<JSON>.
+
=item C<html> and C<htm>
This is actually a custom type intended for use with CGI::Ex::Validate.
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION
$CALL_LEVEL
- $ON $SUB $QR1 $QR2 $full_filename);
+ $ON $SUB $QR1 $QR2 $full_filename $DEPARSE);
use strict;
use Exporter;
-$VERSION = '2.04';
+$VERSION = '2.05';
@ISA = qw(Exporter);
@EXPORT = qw(dex dex_warn dex_text dex_html ctrace dex_trace);
@EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug);
### is on or off
sub on { $ON = 1 };
sub off { $ON = 0; }
-&on();
-sub set_deparse {
- $Data::Dumper::Deparse = eval {require B::Deparse};
-}
+sub set_deparse { $DEPARSE = 1 }
###----------------------------------------------------------------###
BEGIN {
- ### setup the Data::Dumper usage
- $Data::Dumper::Sortkeys = 1 if ! defined $Data::Dumper::Sortkeys; # not avail pre 5.8
- $Data::Dumper::Useqq = 1 if ! defined $Data::Dumper::Useqq;
- $Data::Dumper::Quotekeys = 0 if ! defined $Data::Dumper::Quotekeys;
- $Data::Dumper::Pad = ' ' if ! defined $Data::Dumper::Pad;
- #$Data::Dumper::Deparse = 1 if ! defined $Data::Dumper::Deparse; # very useful
+ on();
+
$SUB = sub {
+ ### setup the Data::Dumper usage
+ local $Data::Dumper::Deparse = $DEPARSE && eval {require B::Deparse};
+ local $Data::Dumper::Pad = ' ';
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Useqq = 1;
+ local $Data::Dumper::Quotekeys = 0;
+
require Data::Dumper;
return Data::Dumper->Dumpperl(\@_);
};
use base qw(Exporter);
BEGIN {
- $VERSION = '2.04';
+ $VERSION = '2.05';
@EXPORT = qw(form_fill);
@EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
};
use base qw(Exporter);
BEGIN {
- $VERSION = '2.04';
+ $VERSION = '2.05';
@EXPORT = qw(JSONDump);
@EXPORT_OK = @EXPORT;
my $quote = $self->{'single_quote'} ? "'" : '"';
$str =~ s/\\/\\\\/g;
- $str =~ s/\r/\\\r/g;
- $str =~ s/\t/\\\t/g;
+ $str =~ s/\r/\\r/g;
+ $str =~ s/\t/\\t/g;
$self->{'single_quote'} ? $str =~ s/\'/\\\'/g : $str =~ s/\"/\\\"/g;
### allow for really odd chars
with single quotes. Otherwise values are quoted with double quotes.
JSONDump("a", {single_quote => 0});
- JSONDump('a', {single_quote => 0});
+ JSONDump("a", {single_quote => 1});
Would print
0 or 1. Default 1 (true)
-If true, then key/value pairs of hashrefs will be sorted will be output in sorted order.
+If true, then key/value pairs of hashrefs will be output in sorted order.
=item play_coderefs
=item skip_keys
-Should contain an arrayref of keys or a hashref whose keys are the keys to skip. Default
-is unset. Any keys of hashrefs that are in the skip_keys item will not be included in
-the javascript output.
+Should contain an arrayref of keys or a hashref whose keys are the
+keys to skip. Default is unset. Any keys of hashrefs (including
+nested hashrefs) that are in the skip_keys item will not be included
+in the javascript output.
JSONDump({a => 1, b => 1}, {skip_keys => ['a'], pretty => 0});
=item skip_keys_qr
-Similar to skip_keys but should contain a regex. Any keys of hashrefs that match the
-skip_keys_qr regex will not be included in the javascript output.
+Similar to skip_keys but should contain a regex. Any keys of hashrefs
+(including nested hashrefs) that match the skip_keys_qr regex will not
+be included in the javascript output.
JSONDump({a => 1, _b => 1}, {skip_keys_qr => qr/^_/, pretty => 0});
+"with plenty of embedded newlines\n"
+"and is greater than 80 characters.\n"
-If the string is less than 80 characters, or if str_nl is set to '', then the escaped
+If the string is less than 80 characters, or if str_nl is set to "", then the escaped
string will be contained on a single line.
=back
);
BEGIN {
- $VERSION = '2.04';
+ $VERSION = '2.05';
$PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
$PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
defined => sub { 1 },
indent => \&vmethod_indent,
int => sub { local $^W; int $_[0] },
+ fmt => \&vmethod_as_scalar,
'format' => \&vmethod_format,
hash => sub { {value => $_[0]} },
html => sub { local $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; s/\"/"/g; $_ },
$LIST_OPS = {
as => \&vmethod_as_list,
first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
+ fmt => \&vmethod_as_list,
grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
hash => sub { local $^W; my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } },
each => sub { [%{ $_[0] }] },
exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
+ fmt => \&vmethod_as_hash,
hash => sub { $_[0] },
import => sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
item => sub { my ($h, $k) = @_; return '' if ! defined $k || $k =~ $QR_PRIVATE; $h->{$k} },
| Hash.keys
| List.join(", ") %] # = a, b
-=item Added "as" scalar, list, and hash virtual methods.
+=item Added "fmt" scalar, list, and hash virtual methods.
- [% list.as("%s", ", ") %]
+ [% list.fmt("%s", ", ") %]
- [% hash.as("%s => %s", "\n") %]
+ [% hash.fmt("%s => %s", "\n") %]
=item Whitespace is less meaningful. (TT3)
[% a = 1.2e-20 %]
- [% 123.as('%.3e') %] # = 1.230e+02
+ [% 123.fmt('%.3e') %] # = 1.230e+02
=item Allow for hexidecimal input. (TT3)
[% a = 0xff0000 %][% a %] # = 16711680
- [% a = 0xff2 / 0xd; a.as('%x') %] # = 13a
+ [% a = 0xff2 / 0xd; a.fmt('%x') %] # = 13a
=item FOREACH variables can be nested.
[% 314159e-5 + 0 %] Prints 3.14159.
- [% .0000001.as('%.1e') %] Prints 1.0e-07
+ [% .0000001.fmt('%.1e') %] Prints 1.0e-07
Hexidecimal input is also supported.
[% 0xff + 0 %] Prints 255
- [% 48875.as('%x') %] Prints beeb
+ [% 48875.fmt('%x') %] Prints beeb
=item Single quoted strings.
[% item = 'foo' %][% item.0 %] Returns self. Allows for scalars to mask as arrays (scalars
already will, but this allows for more direct access).
-=item as
-
- [% item.as('%d') %]
-
-Similar to format. Returns a string formatted with the passed pattern. Default pattern is %s.
-
=item chunk
[% item.chunk(60).join("\n") %] Split string up into a list of chunks of text 60 chars wide.
Same as the redirect filter.
+=item fmt
+
+ [% item.fmt('%d') %]
+
+Similar to format. Returns a string formatted with the passed pattern. Default pattern is %s.
+
=item format
[% item.format('%d') %] Print the string out in the specified format. It is similar to
=over 4
-=item as
+=item fmt
- [% mylist.as('%s', ', ') %]
+ [% mylist.fmt('%s', ', ') %]
Passed a pattern and an string to join on. Returns a string of the values of the list
formatted with the passed pattern and joined with the passed string.
=over 4
-=item as
+=item fmt
- [% myhash.as('%s => %s', "\n") %]
+ [% myhash.fmt('%s => %s', "\n") %]
Passed a pattern and an string to join on. Returns a string of the key/value pairs
of the hash formatted with the passed pattern and joined with the passed string.
@UNSUPPORTED_BROWSERS
);
-$VERSION = '2.04';
+$VERSION = '2.05';
$DEFAULT_EXT = 'val';
$QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;
process_ok("[% ' ' | uri %]" => '%20');
-process_ok('[% "one".as %]' => "one") if ! $is_tt;
-process_ok('[% 2.as("%02d") %]' => "02") if ! $is_tt;
+process_ok('[% "one".fmt %]' => "one") if ! $is_tt;
+process_ok('[% 2.fmt("%02d") %]' => "02") if ! $is_tt;
-process_ok('[% [1..3].as %]' => "1 2 3") if ! $is_tt;
-process_ok('[% [1..3].as("%02d") %]' => '01 02 03') if ! $is_tt;
-process_ok('[% [1..3].as("%s", ", ") %]' => '1, 2, 3') if ! $is_tt;
+process_ok('[% [1..3].fmt %]' => "1 2 3") if ! $is_tt;
+process_ok('[% [1..3].fmt("%02d") %]' => '01 02 03') if ! $is_tt;
+process_ok('[% [1..3].fmt("%s", ", ") %]' => '1, 2, 3') if ! $is_tt;
-process_ok('[% {a => "B", c => "D"}.as %]' => "a\tB\nc\tD") if ! $is_tt;
-process_ok('[% {a => "B", c => "D"}.as("%s:%s") %]' => "a:B\nc:D") if ! $is_tt;
-process_ok('[% {a => "B", c => "D"}.as("%s:%s", "; ") %]' => "a:B; c:D") if ! $is_tt;
+process_ok('[% {a => "B", c => "D"}.fmt %]' => "a\tB\nc\tD") if ! $is_tt;
+process_ok('[% {a => "B", c => "D"}.fmt("%s:%s") %]' => "a:B\nc:D") if ! $is_tt;
+process_ok('[% {a => "B", c => "D"}.fmt("%s:%s", "; ") %]' => "a:B; c:D") if ! $is_tt;
###----------------------------------------------------------------###
### virtual objects