diff options
Diffstat (limited to 'lib/CGI')
| -rw-r--r-- | lib/CGI/Carp.pm | 78 | ||||
| -rw-r--r-- | lib/CGI/Cookie.pm | 17 | ||||
| -rw-r--r-- | lib/CGI/Pretty.pm | 132 | ||||
| -rw-r--r-- | lib/CGI/t/carp.t | 24 | ||||
| -rwxr-xr-x | lib/CGI/t/html.t | 8 | ||||
| -rwxr-xr-x | lib/CGI/t/pretty.t | 97 |
6 files changed, 272 insertions, 84 deletions
diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm index bc3d1c3968..ce9b40719f 100644 --- a/lib/CGI/Carp.pm +++ b/lib/CGI/Carp.pm @@ -169,6 +169,39 @@ content where HTML comments are not allowed: Note: In this respect warningsToBrowser() differs fundamentally from fatalsToBrowser(), which you should never call yourself! +=head1 OVERRIDING THE NAME OF THE PROGRAM + +CGI::Carp includes the name of the program that generated the error or +warning in the messages written to the log and the browser window. +Sometimes, Perl can get confused about what the actual name of the +executed program was. In these cases, you can override the program +name that CGI::Carp will use for all messages. + +The quick way to do that is to tell CGI::Carp the name of the program +in its use statement. You can do that by adding +"name=cgi_carp_log_name" to your "use" statement. For example: + + use CGI::Carp qw(name=cgi_carp_log_name); + +. If you want to change the program name partway through the program, +you can use the C<set_progname()> function instead. It is not +exported by default, you must import it explicitly by saying + + use CGI::Carp qw(set_progname); + +Once you've done that, you can change the logged name of the program +at any time by calling + + set_progname(new_program_name); + +You can set the program back to the default by calling + + set_progname(undef); + +Note that this override doesn't happen until after the program has +compiled, so any compile-time errors will still show up with the +non-overridden program name + =head1 CHANGE LOG 1.05 carpout() added and minor corrections by Marc Hedlund @@ -203,6 +236,9 @@ fatalsToBrowser(), which you should never call yourself! (hack alert!) in order to accomodate various combinations of Perl and mod_perl. +1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support + for overriding program name. + =head1 AUTHORS Copyright 1995-2002, Lincoln D. Stein. All rights reserved. @@ -216,6 +252,10 @@ Address bug reports and comments to: lstein@cshl.org Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form, CGI::Response + if (defined($CGI::Carp::PROGNAME)) + { + $file = $CGI::Carp::PROGNAME; + } =cut @@ -227,17 +267,26 @@ use File::Spec; @ISA = qw(Exporter); @EXPORT = qw(confess croak carp); -@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck); +@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_progname cluck ^name=); $main::SIG{__WARN__}=\&CGI::Carp::warn; -$main::SIG{__DIE__}=\&CGI::Carp::die; -$CGI::Carp::VERSION = '1.23'; +*CORE::GLOBAL::die = \&CGI::Carp::die; +$CGI::Carp::VERSION = '1.24'; $CGI::Carp::CUSTOM_MSG = undef; # fancy import routine detects and handles 'errorWrap' specially. sub import { my $pkg = shift; my(%routines); + my(@name); + + if (@name=grep(/^name=/,@_)) + { + my($n) = (split(/=/,$name[0]))[1]; + set_progname($n); + @_=grep(!/^name=/,@_); + } + grep($routines{$_}++,@_,@EXPORT); $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; $WARN++ if $routines{'warningsToBrowser'}; @@ -262,14 +311,24 @@ sub stamp { my $time = scalar(localtime); my $frame = 0; my ($id,$pack,$file,$dev,$dirs); - do { - $id = $file; - ($pack,$file) = caller($frame++); - } until !$file; + if (defined($CGI::Carp::PROGNAME)) { + $id = $CGI::Carp::PROGNAME; + } else { + do { + $id = $file; + ($pack,$file) = caller($frame++); + } until !$file; + } ($dev,$dirs,$id) = File::Spec->splitpath($id); return "[$time] $id: "; } +sub set_progname { + $CGI::Carp::PROGNAME = shift; + return $CGI::Carp::PROGNAME; +} + + sub warn { my $message = shift; my($file,$line,$id) = id(1); @@ -294,7 +353,10 @@ sub _warn { } } -sub ineval { $^S || _longmess() =~ /eval [\{\']/m } +sub ineval { + (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m +} + # The mod_perl package Apache::Registry loads CGI programs by calling # eval. These evals don't count when looking at the stack backtrace. diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm index 1e1cfde87c..7c7434c2b8 100644 --- a/lib/CGI/Cookie.pm +++ b/lib/CGI/Cookie.pm @@ -13,7 +13,7 @@ package CGI::Cookie; # wish, but if you redistribute a modified version, please attach a note # listing the modifications you have made. -$CGI::Cookie::VERSION='1.20'; +$CGI::Cookie::VERSION='1.21'; use CGI::Util qw(rearrange unescape escape); use overload '""' => \&as_string, @@ -117,6 +117,7 @@ sub new { $self->domain($domain) if defined $domain; $self->secure($secure) if defined $secure; $self->expires($expires) if defined $expires; +# $self->max_age($expires) if defined $expires; return $self; } @@ -124,11 +125,12 @@ sub as_string { my $self = shift; return "" unless $self->name; - my(@constant_values,$domain,$path,$expires,$secure); + my(@constant_values,$domain,$path,$expires,$max_age,$secure); - push(@constant_values,"domain=$domain") if $domain = $self->domain; - push(@constant_values,"path=$path") if $path = $self->path; + push(@constant_values,"domain=$domain") if $domain = $self->domain; + push(@constant_values,"path=$path") if $path = $self->path; push(@constant_values,"expires=$expires") if $expires = $self->expires; + push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age; push(@constant_values,"secure") if $secure = $self->secure; my($key) = escape($self->name); @@ -190,6 +192,13 @@ sub expires { return $self->{'expires'}; } +sub max_age { + my $self = shift; + my $expires = shift; + $self->{'max-age'} = CGI::Util::expire_calc($expires)-time if defined $expires; + return $self->{'max-age'}; +} + sub path { my $self = shift; my $path = shift; diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm index ef606e9758..c498db5207 100644 --- a/lib/CGI/Pretty.pm +++ b/lib/CGI/Pretty.pm @@ -10,7 +10,7 @@ package CGI::Pretty; use strict; use CGI (); -$CGI::Pretty::VERSION = '1.05_00'; +$CGI::Pretty::VERSION = '1.07_00'; $CGI::DefaultClass = __PACKAGE__; $CGI::Pretty::AutoloadClass = 'CGI'; @CGI::Pretty::ISA = qw( CGI ); @@ -19,18 +19,27 @@ initialize_globals(); sub _prettyPrint { my $input = shift; + return if !$$input; + return if !$CGI::Pretty::LINEBREAK || !$CGI::Pretty::INDENT; + +# print STDERR "'", $$input, "'\n"; foreach my $i ( @CGI::Pretty::AS_IS ) { - if ( $$input =~ /<\/$i>/si ) { - my ( $a, $b, $c, $d, $e ) = $$input =~ /(.*)<$i(\s?)(.*?)>(.*?)<\/$i>(.*)/si; - _prettyPrint( \$a ); - _prettyPrint( \$e ); + if ( $$input =~ m{</$i>}si ) { + my ( $a, $b, $c ) = $$input =~ m{(.*)(<$i[\s/>].*?</$i>)(.*)}si; + next if !$b; + $a ||= ""; + $c ||= ""; + + _prettyPrint( \$a ) if $a; + _prettyPrint( \$c ) if $c; - $$input = "$a<$i$b$c>$d</$i>$e"; + $b ||= ""; + $$input = "$a$b$c"; return; } } - $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK; + $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g; } sub comment { @@ -44,7 +53,6 @@ sub comment { sub _make_tag_func { my ($self,$tagname) = @_; - return $self->SUPER::_make_tag_func($tagname) if $tagname=~/^(start|end)_/; # As Lincoln as noted, the last else clause is VERY hairy, and it # took me a while to figure out what I was trying to do. @@ -57,60 +65,74 @@ sub _make_tag_func { # guru, so if anybody wants to contribute something that would # be quicker, easier to read, etc, I would be more than # willing to put it in - Brian - - return qq{ - sub $tagname { - # handle various cases in which we're called - # most of this bizarre stuff is to avoid -w errors - shift if \$_[0] && - (ref(\$_[0]) && - (substr(ref(\$_[0]),0,3) eq 'CGI' || - UNIVERSAL::isa(\$_[0],'CGI'))); - - my(\$attr) = ''; - if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') { - my(\@attr) = make_attributes(shift); - \$attr = " \@attr" if \@attr; - } - my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E"); - return \$tag unless \@_; - - my \@result; - my \$NON_PRETTIFY_ENDTAGS = join "", map { "</\$_>" } \@CGI::Pretty::AS_IS; - - if ( \$NON_PRETTIFY_ENDTAGS =~ /\$untag/ ) { + my $func = qq" + sub $tagname {"; + + $func .= q' + shift if $_[0] && + (ref($_[0]) && + (substr(ref($_[0]),0,3) eq "CGI" || + UNIVERSAL::isa($_[0],"CGI"))); + my($attr) = ""; + if (ref($_[0]) && ref($_[0]) eq "HASH") { + my(@attr) = make_attributes(shift()||undef,1); + $attr = " @attr" if @attr; + }'; + + if ($tagname=~/start_(\w+)/i) { + $func .= qq! + return "<\L$1\E\$attr>\$CGI::Pretty::LINEBREAK";} !; + } elsif ($tagname=~/end_(\w+)/i) { + $func .= qq! + return "<\L/$1\E>\$CGI::Pretty::LINEBREAK"; } !; + } else { + $func .= qq# + return ( \$CGI::XHTML ? "<\L$tagname\E\$attr />" : "<\L$tagname\E\$attr>" ) . + \$CGI::Pretty::LINEBREAK unless \@_; + my(\$tag,\$untag) = ("<\L$tagname\E\$attr>","</\L$tagname>\E"); + + my \%ASIS = map { lc("\$_") => 1 } \@CGI::Pretty::AS_IS; + my \@args; + if ( \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT ) { + if(ref(\$_[0]) eq 'ARRAY') { + \@args = \@{\$_[0]} + } else { + foreach (\@_) { + \$args[0] .= \$_; + \$args[0] .= \$CGI::Pretty::LINEBREAK if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 0; + chomp \$args[0] if exists \$ASIS{ "\L$tagname\E" }; + + \$args[0] .= \$" if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 1; + } + chop \$args[0]; + } + } + else { + \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_"; + } + + my \@result; + if ( exists \$ASIS{ "\L$tagname\E" } ) { \@result = map { "\$tag\$_\$untag\$CGI::Pretty::LINEBREAK" } - (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; + \@args; } else { - my \@args; - if(ref(\$_[0]) eq 'ARRAY') { - \@args = \@{\$_[0]} - } else { - foreach (\@_) { - \$args[0] .= \$_; - \$args[0] .= " " unless \$args[0] =~ /\\s\$/; - } - chop \$args[0]; - } \@result = map { chomp; - if ( \$_ !~ /<\\// ) { - s/\$CGI::Pretty::LINEBREAK/\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT/g if \$CGI::Pretty::LINEBREAK; - } - else { - my \$tmp = \$_; - CGI::Pretty::_prettyPrint( \\\$tmp ); - \$_ = \$tmp; - } - "\$tag\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT\$_\$CGI::Pretty::LINEBREAK\$untag\$CGI::Pretty::LINEBREAK" + my \$tmp = \$_; + CGI::Pretty::_prettyPrint( \\\$tmp ); + \$tag . \$CGI::Pretty::LINEBREAK . + \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK . + \$untag . \$CGI::Pretty::LINEBREAK } \@args; } - local \$" = ""; + local \$" = "" if \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT; return "\@result"; - } - }; + }#; + } + + return $func; } sub start_html { @@ -136,10 +158,10 @@ sub initialize_globals { $CGI::Pretty::INDENT = "\t"; # This is the string used for seperation between tags - $CGI::Pretty::LINEBREAK = "\n"; + $CGI::Pretty::LINEBREAK = $/; # These tags are not prettify'd. - @CGI::Pretty::AS_IS = qw( a pre code script textarea ); + @CGI::Pretty::AS_IS = qw( a pre code script textarea td ); 1; } diff --git a/lib/CGI/t/carp.t b/lib/CGI/t/carp.t index b17f0142e3..0de6a101ce 100644 --- a/lib/CGI/t/carp.t +++ b/lib/CGI/t/carp.t @@ -14,7 +14,7 @@ BEGIN { use strict; -use Test::More tests => 42; +use Test::More tests => 47; use IO::Handle; BEGIN { use_ok('CGI::Carp') }; @@ -159,6 +159,28 @@ is($CGI::Carp::CUSTOM_MSG, CGI::Carp::set_message(''), #----------------------------------------------------------------------------- +# Test set_progname +#----------------------------------------------------------------------------- + +import CGI::Carp qw(name=new_progname); +is($CGI::Carp::PROGNAME, + 'new_progname', + 'CGI::Carp::import set program name correctly'); + +is(CGI::Carp::set_progname('newer_progname'), + 'newer_progname', + 'CGI::Carp::set_progname returns new program name'); + +is($CGI::Carp::PROGNAME, + 'newer_progname', + 'CGI::Carp::set_progname program name set correctly'); + +# set the message back to the empty string so that the tests later +# work properly. +is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly"); +is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly"); + +#----------------------------------------------------------------------------- # Test warnings_to_browser #----------------------------------------------------------------------------- diff --git a/lib/CGI/t/html.t b/lib/CGI/t/html.t index b101e4da0f..1af6754b33 100755 --- a/lib/CGI/t/html.t +++ b/lib/CGI/t/html.t @@ -67,14 +67,14 @@ test(13,start_html() ."\n" eq <<END,"start_html()"); <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"><head><title>Untitled Document</title> </head><body> END ; test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR",-lang=>'fr') ."\n" eq <<END,"start_html()"); <!DOCTYPE html PUBLIC "-//IETF//DTD HTML 3.2//FR"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="fr"><head><title>Untitled Document</title> +<html xmlns="http://www.w3.org/1999/xhtml" lang="fr" xml:lang="fr"><head><title>Untitled Document</title> </head><body> END ; @@ -83,7 +83,7 @@ test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"><head><title>The world of foo</title> </head><body> END ; @@ -94,7 +94,7 @@ test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Co test(18,start_h3 eq '<h3>'); test(19,end_h3 eq '</h3>'); test(20,start_table({-border=>undef}) eq '<table border>'); -test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); charset('utf-8'); if (ord("\t") == 9) { test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); diff --git a/lib/CGI/t/pretty.t b/lib/CGI/t/pretty.t index 033bcbfb30..d3c19c0c98 100755 --- a/lib/CGI/t/pretty.t +++ b/lib/CGI/t/pretty.t @@ -1,23 +1,16 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir 't' if -d 't'; - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - } else { - unshift @INC, qw( ../blib/lib ../blib/arch lib ); - } -} +#!/bin/perl -w use strict; -use Test::More tests => 5; +use lib '.', 't/lib','../blib/lib','./blib/lib'; +use Test::More tests => 18; BEGIN { use_ok('CGI::Pretty') }; # This is silly use_ok should take arguments use CGI::Pretty (':all'); -is(h1(), '<h1>',"single tag"); +is(h1(), '<h1 /> +',"single tag"); is(ol(li('fred'),li('ethel')), <<HTML, "basic indentation"); <ol> @@ -38,6 +31,26 @@ is(p('hi',pre('there'),'frog'), <<HTML, "<pre> tags"); </p> HTML +is(h1({-align=>'CENTER'},'fred'), <<HTML, "open/close tag with attribute"); +<h1 align="CENTER"> + fred +</h1> +HTML + +is(h1({-align=>undef},'fred'), <<HTML,"open/close tag with orphan attribute"); +<h1 align> + fred +</h1> +HTML + +is(h1({-align=>'CENTER'},['fred','agnes']), <<HTML, "distributive tag with attribute"); +<h1 align="CENTER"> + fred +</h1> +<h1 align="CENTER"> + agnes +</h1> +HTML is(p('hi',a({-href=>'frog'},'there'),'frog'), <<HTML, "as-is"); <p> @@ -46,3 +59,63 @@ is(p('hi',a({-href=>'frog'},'there'),'frog'), <<HTML, "as-is"); </p> HTML +is(p([ qw( hi there frog ) ] ), <<HTML, "array-reference"); +<p> + hi +</p> +<p> + there +</p> +<p> + frog +</p> +HTML + +is(p(p(p('hi'), 'there' ), 'frog'), <<HTML, "nested tags"); +<p> + <p> + <p> + hi + </p> + there + </p> + frog +</p> +HTML + +is(table(TR(td(table(TR(td('hi', 'there', 'frog')))))), <<HTML, "nested as-is tags"); +<table> + <tr> + <td><table> + <tr> + <td>hi there frog</td> + </tr> + </table></td> + </tr> +</table> +HTML + +is(table(TR(td(table(TR(td( [ qw( hi there frog ) ])))))), <<HTML, "nested as-is array-reference"); +<table> + <tr> + <td><table> + <tr> + <td>hi</td> + <td>there</td> + <td>frog</td> + </tr> + </table></td> + </tr> +</table> +HTML + +$CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = ""; + +is(h1(), '<h1 />',"single tag (pretty turned off)"); +is(h1('fred'), '<h1>fred</h1>',"open/close tag (pretty turned off)"); +is(h1('fred','agnes','maura'), '<h1>fred agnes maura</h1>',"open/close tag multiple (pretty turned off)"); +is(h1({-align=>'CENTER'},'fred'), '<h1 align="CENTER">fred</h1>',"open/close tag with attribute (pretty turned off)"); +is(h1({-align=>undef},'fred'), '<h1 align>fred</h1>',"open/close tag with orphan attribute (pretty turned off)"); +is(h1({-align=>'CENTER'},['fred','agnes']), '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', + "distributive tag with attribute (pretty turned off)"); + |