diff options
| author | Charles Bailey <bailey@newman.upenn.edu> | 2000-05-23 23:35:13 +0000 |
|---|---|---|
| committer | bailey <bailey@newman.upenn.edu> | 2000-05-23 23:35:13 +0000 |
| commit | ee8c7f5465f003860e2347a2946abacac39bd9b9 (patch) | |
| tree | fb05d3d164ae556f95f63a324d3fbb66c4a36517 /lib | |
| parent | 099f76bb8eab859fbb7b90260152c1ead1bf3022 (diff) | |
| download | perl-ee8c7f5465f003860e2347a2946abacac39bd9b9.tar.gz | |
Resync with mainline prior to post-5.6.0 updates
p4raw-id: //depot/vmsperl@6111
Diffstat (limited to 'lib')
89 files changed, 5004 insertions, 1238 deletions
diff --git a/lib/CGI.pm b/lib/CGI.pm index 3e032578b2..63805544f8 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -17,12 +17,13 @@ require 5.004; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.19 1999/08/31 17:04:37 lstein Exp $'; -$CGI::VERSION='2.56'; +$CGI::revision = '$Id: CGI.pm,v 1.30 2000/03/28 21:31:40 lstein Exp $'; +$CGI::VERSION='2.66'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. # $TempFile::TMPDIRECTORY = '/usr/tmp'; +use CGI::Util qw(rearrange make_attributes unescape escape expires); # >>>>> Here are some globals that you might want to adjust <<<<<< sub initialize_globals { @@ -31,24 +32,31 @@ sub initialize_globals { # Change this to the preferred DTD to print in start_html() # or use default_dtd('text of DTD to use'); - $DEFAULT_DTD = '-//IETF//DTD HTML//EN'; + $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', + 'http://www.w3.org/TR/html4/loose.dtd' ] ; + + # Set this to 1 to enable NOSTICKY scripts + # or: + # 1) use CGI qw(-nosticky) + # 2) $CGI::nosticky(1) + $NOSTICKY = 0; # Set this to 1 to enable NPH scripts # or: # 1) use CGI qw(-nph) - # 2) $CGI::nph(1) + # 2) CGI::nph(1) # 3) print header(-nph=>1) $NPH = 0; - # Set this to 1 to disable debugging from the - # command line - $NO_DEBUG = 0; + # Set this to 1 to enable debugging from @ARGV + # Set to 2 to enable debugging from STDIN + $DEBUG = 1; # Set this to 1 to make the temporary files created # during file uploads safe from prying eyes # or do... # 1) use CGI qw(:private_tempfiles) - # 2) $CGI::private_tempfiles(1); + # 2) CGI::private_tempfiles(1); $PRIVATE_TEMPFILES = 0; # Set this to a positive value to limit the size of a POSTing @@ -65,7 +73,7 @@ sub initialize_globals { $HEADERS_ONCE = 0; # separate the name=value pairs by semicolons rather than ampersands - $USE_PARAM_SEMICOLONS = 0; + $USE_PARAM_SEMICOLONS = 1; # Other globals that you shouldn't worry about. undef $Q; @@ -153,27 +161,6 @@ if ($OS eq 'VMS') { $CRLF = "\015\012"; } -if ($EBCDIC) { -@A2E = ( - 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, - 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, -240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, -124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, -215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, -121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, -151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, - 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, - 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, - 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, -144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, -100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, -172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, - 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, -140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 - ); -} - if ($needs_binmode) { $CGI::DefaultClass->binmode(main::STDOUT); $CGI::DefaultClass->binmode(main::STDIN); @@ -184,7 +171,7 @@ if ($needs_binmode) { ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em tt u i b blockquote pre img a address cite samp dfn html head base body Link nextid title meta kbd start_html end_html - input Select option comment/], + input Select option comment charset escapeHTML/], ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param embed basefont style span layer ilayer font frameset frame script small big/], ':netscape'=>[qw/blink fontsize center/], @@ -195,7 +182,7 @@ if ($needs_binmode) { ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump raw_cookie request_method query_string Accept user_agent remote_host content_type remote_addr referer server_name server_software server_port server_protocol - virtual_host remote_ident auth_type http use_named_parameters + virtual_host remote_ident auth_type http save_parameters restore_parameters param_fetch remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error/], @@ -259,9 +246,9 @@ sub new { my($class,$initializer) = @_; my $self = {}; bless $self,ref $class || $class || $DefaultClass; - if ($MOD_PERL) { - Apache->request->register_cleanup(\&CGI::_reset_globals); - undef $NPH; + if ($MOD_PERL && defined Apache->request) { + Apache->request->register_cleanup(\&CGI::_reset_globals); + undef $NPH; } $self->_reset_globals if $PERLEX; $self->init($initializer); @@ -291,10 +278,10 @@ sub param { # For compatibility between old calling style and use_named_parameters() style, # we have to special case for a single parameter present. if (@p > 1) { - ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); + ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); my(@values); - if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) { + if (substr($p[0],0,1) eq '-') { @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); } else { foreach ($value,@other) { @@ -322,7 +309,7 @@ sub self_or_default { $Q = $CGI::DefaultClass->new unless defined($Q); unshift(@_,$Q); } - return @_; + return wantarray ? @_ : $Q; } sub self_or_CGI { @@ -432,6 +419,7 @@ sub init { $query_string = Apache->request->args; } else { $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'}; } last METHOD; } @@ -450,13 +438,13 @@ sub init { # Check the command line and then the standard input for data. # We use the shellwords package in order to behave the way that # UN*X programmers expect. - $query_string = read_from_cmdline() unless $NO_DEBUG; + $query_string = read_from_cmdline() if $DEBUG; } # We now have the query string in hand. We do slightly # different things for keyword lists and parameter lists. if (defined $query_string && $query_string) { - if ($query_string =~ /=/) { + if ($query_string =~ /[&=;]/) { $self->parse_params($query_string); } else { $self->add_parameter('keywords'); @@ -479,6 +467,9 @@ sub init { # Clear out our default submission button flag if present $self->delete('.submit'); $self->delete('.cgifields'); + + # set charset to the safe ISO-8859-1 + $self->charset('ISO-8859-1'); $self->save_request unless $initializer; } @@ -518,29 +509,6 @@ sub cgi_error { return $self->{'.cgi_error'}; } -# unescape URL-encoded data -sub unescape { - shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass); - my $todecode = shift; - return undef unless defined($todecode); - $todecode =~ tr/+/ /; # pluses become spaces - if ($EBCDIC) { - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge; - } else { - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; - } - return $todecode; -} - -# URL-encode data -sub escape { - shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass); - my $toencode = shift; - return undef unless defined($toencode); - $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; - return $toencode; -} - sub save_request { my($self) = @_; # We're going to play with the package globals now so that if we get called @@ -548,7 +516,8 @@ sub save_request { # us to have several of these objects. @QUERY_PARAM = $self->param; # save list of parameters foreach (@QUERY_PARAM) { - $QUERY_PARAM{$_}=$self->{$_}; + next unless defined $_; + $QUERY_PARAM{$_}=$self->{$_}; } } @@ -558,6 +527,7 @@ sub parse_params { my($param,$value); foreach (@pairs) { ($param,$value) = split('=',$_,2); + $value = '' unless defined $value; $param = unescape($param); $value = unescape($value); $self->add_parameter($param); @@ -567,6 +537,7 @@ sub parse_params { sub add_parameter { my($self,$param)=@_; + return unless defined $param; push (@{$self->{'.parameters'}},$param) unless defined($self->{$param}); } @@ -586,16 +557,14 @@ sub binmode { sub _make_tag_func { my ($self,$tagname) = @_; my $func = qq( - sub $tagname { - shift if \$_[0] && -# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || - (ref(\$_[0]) && - (substr(ref(\$_[0]),0,3) eq 'CGI' || - UNIVERSAL::isa(\$_[0],'CGI'))); - + sub $tagname { + 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() ); + my(\@attr) = make_attributes(shift()||undef,1); \$attr = " \@attr" if \@attr; } ); @@ -607,7 +576,8 @@ sub _make_tag_func { $func .= qq# my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E"); return \$tag unless \@_; - my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; + my \@result = map { "\$tag\$_\$untag" } + (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; return "\@result"; }#; } @@ -620,47 +590,6 @@ sub AUTOLOAD { goto &$func; } -# PRIVATE SUBROUTINE -# Smart rearrangement of parameters to allow named parameter -# calling. We do the rearangement if: -# 1. The first parameter begins with a - -# 2. The use_named_parameters() method returns true -sub rearrange { - my($self,$order,@param) = @_; - return () unless @param; - - if (ref($param[0]) eq 'HASH') { - @param = %{$param[0]}; - } else { - return @param - unless (defined($param[0]) && substr($param[0],0,1) eq '-') - || $self->use_named_parameters; - } - - # map parameters into positional indices - my ($i,%pos); - $i = 0; - foreach (@$order) { - foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; } - $i++; - } - - my (@result,%leftover); - $#result = $#$order; # preextend - while (@param) { - my $key = uc(shift(@param)); - $key =~ s/^\-//; - if (exists $pos{$key}) { - $result[$pos{$key}] = shift(@param); - } else { - $leftover{$key} = shift(@param); - } - } - - push (@result,$self->make_attributes(\%leftover)) if %leftover; - @result; -} - sub _compile { my($func) = $AUTOLOAD; my($pack,$func_name); @@ -711,8 +640,11 @@ sub _setup_symbols { foreach (@_) { $HEADERS_ONCE++, next if /^[:-]unique_headers$/; $NPH++, next if /^[:-]nph$/; - $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; + $NOSTICKY++, next if /^[:-]nosticky$/; + $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; + $DEBUG=2, next if /^[:-][Dd]ebug$/; $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; $EXPORT{$_}++, next if /^[:-]any$/; $compile++, next if /^[:-]compile$/; @@ -736,6 +668,12 @@ sub _setup_symbols { _compile_all(keys %EXPORT) if $compile; } +sub charset { + my ($self,$charset) = self_or_default(@_); + $self->{'.charset'} = $charset if defined $charset; + $self->{'.charset'}; +} + ############################################################################### ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### ############################################################################### @@ -756,21 +694,6 @@ END_OF_FUNC sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; } END_OF_FUNC -'use_named_parameters' => <<'END_OF_FUNC', -#### Method: use_named_parameters -# Force CGI.pm to use named parameter-style method calls -# rather than positional parameters. The same effect -# will happen automatically if the first parameter -# begins with a -. -sub use_named_parameters { - my($self,$use_named) = self_or_default(@_); - return $self->{'.named'} unless defined ($use_named); - - # stupidity to avoid annoying warnings - return $self->{'.named'}=$use_named; -} -END_OF_FUNC - 'new_MultipartBuffer' => <<'END_OF_FUNC', # Create a new multipart buffer sub new_MultipartBuffer { @@ -920,13 +843,16 @@ END_OF_FUNC 'TIEHASH' => <<'END_OF_FUNC', sub TIEHASH { return $_[1] if defined $_[1]; - return $Q || new shift; + return $Q ||= new shift; } END_OF_FUNC 'STORE' => <<'END_OF_FUNC', sub STORE { - $_[0]->param($_[1],split("\0",$_[2])); + my $self = shift; + my $tag = shift; + my @vals = split("\0",shift); + $self->param(-name=>$tag,-value=>\@vals); } END_OF_FUNC @@ -976,7 +902,7 @@ END_OF_FUNC 'append' => <<'EOF', sub append { my($self,@p) = @_; - my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p); + my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); if (@values) { $self->add_parameter($name); @@ -1030,21 +956,6 @@ sub version { } END_OF_FUNC -'make_attributes' => <<'END_OF_FUNC', -sub make_attributes { - my($self,$attr) = @_; - return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; - my(@att); - foreach (keys %{$attr}) { - my($key) = $_; - $key=~s/^\-//; # get rid of initial - if present - $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes - push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/); - } - return @att; -} -END_OF_FUNC - #### Method: url_param # Return a parameter in the QUERY_STRING, regardless of # whether this was a POST or a GET @@ -1076,13 +987,13 @@ sub url_param { } END_OF_FUNC -#### Method: dump +#### Method: Dump # Returns a string in which all the known parameter/value # pairs are represented as nested lists, mainly for the purposes # of debugging. #### -'dump' => <<'END_OF_FUNC', -sub dump { +'Dump' => <<'END_OF_FUNC', +sub Dump { my($self) = self_or_default(@_); my($param,$value,@result); return '<UL></UL>' unless $self->param; @@ -1109,7 +1020,7 @@ END_OF_FUNC #### 'as_string' => <<'END_OF_FUNC', sub as_string { - &dump(@_); + &Dump(@_); } END_OF_FUNC @@ -1167,7 +1078,7 @@ END_OF_FUNC 'multipart_init' => <<'END_OF_FUNC', sub multipart_init { my($self,@p) = self_or_default(@_); - my($boundary,@other) = $self->rearrange([BOUNDARY],@p); + my($boundary,@other) = rearrange([BOUNDARY],@p); $boundary = $boundary || '------- =_aaaaaaaaaa0'; $self->{'separator'} = "\n--$boundary\n"; $type = SERVER_PUSH($boundary); @@ -1189,7 +1100,7 @@ END_OF_FUNC 'multipart_start' => <<'END_OF_FUNC', sub multipart_start { my($self,@p) = self_or_default(@_); - my($type,@other) = $self->rearrange([TYPE],@p); + my($type,@other) = rearrange([TYPE],@p); $type = $type || 'text/html'; return $self->header( -type => $type, @@ -1224,11 +1135,18 @@ sub header { return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; - my($type,$status,$cookie,$target,$expires,$nph,@other) = - $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], - STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + my($type,$status,$cookie,$target,$expires,$nph,$charset,@other) = + rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + 'STATUS',['COOKIE','COOKIES'],'TARGET', + 'EXPIRES','NPH','CHARSET'],@p); + + $nph ||= $NPH; + if (defined $charset) { + $self->charset($charset); + } else { + $charset = $self->charset; + } - $nph ||= $NPH; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. foreach (@other) { @@ -1237,6 +1155,7 @@ sub header { } $type ||= 'text/html' unless defined($type); + $type .= "; charset=$charset" if $type ne '' and $type !~ /\bcharset\b/; # Maybe future compatibility. Maybe not. my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; @@ -1296,7 +1215,7 @@ END_OF_FUNC 'redirect' => <<'END_OF_FUNC', sub redirect { my($self,@p) = self_or_default(@_); - my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p); + my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p); $url = $url || $self->self_url; my(@o); foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } @@ -1335,15 +1254,27 @@ END_OF_FUNC sub start_html { my($self,@p) = &self_or_default(@_); my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) = - $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p); + rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p); # strangely enough, the title needs to be escaped as HTML # while the author needs to be escaped as a URL $title = $self->escapeHTML($title || 'Untitled Document'); $author = $self->escape($author); my(@result); - $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|; - push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd; + if ($dtd) { + if (ref $dtd && $ref eq 'ARRAY') { + $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|; + } else { + $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|; + } + } else { + $dtd = $DEFAULT_DTD; + } + if (ref($dtd) && ref($dtd) eq 'ARRAY') { + push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd->[0]"\n\t"$dtd->[1]">)); + } else { + push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)); + } push(@result,"<HTML><HEAD><TITLE>$title</TITLE>"); push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author; @@ -1386,7 +1317,7 @@ sub _style { my $type = 'text/css'; if (ref($style)) { my($src,$code,$stype,@other) = - $self->rearrange([SRC,CODE,TYPE], + rearrange([SRC,CODE,TYPE], '-foo'=>'bar', # a trick to allow the '-' to be omitted ref($style) eq 'ARRAY' ? @$style : %$style); $type = $stype if $stype; @@ -1408,21 +1339,32 @@ sub _script { foreach $script (@scripts) { my($src,$code,$language); if (ref($script)) { # script is a hash - ($src,$code,$language) = - $self->rearrange([SRC,CODE,LANGUAGE], + ($src,$code,$language, $type) = + rearrange([SRC,CODE,LANGUAGE,TYPE], '-foo'=>'bar', # a trick to allow the '-' to be omitted ref($script) eq 'ARRAY' ? @$script : %$script); - + # User may not have specified language + $language ||= 'JavaScript'; + unless (defined $type) { + $type = lc $language; + # strip '1.2' from 'javascript1.2' + $type =~ s/^(\D+).*$/text\/$1/; + } } else { - ($src,$code,$language) = ('',$script,'JavaScript'); + ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript'); } my(@satts); push(@satts,'src'=>$src) if $src; - push(@satts,'language'=>$language || 'JavaScript'); + push(@satts,'language'=>$language); + push(@satts,'type'=>$type); $code = "<!-- Hide script\n$code\n// End script hiding -->" - if $code && $language=~/javascript/i; + if $code && $type=~/javascript/i; + $code = "<!-- Hide script\n$code\n\# End script hiding -->" + if $code && $type=~/perl/i; $code = "<!-- Hide script\n$code\n\# End script hiding -->" - if $code && $language=~/perl/i; + if $code && $type=~/tcl/i; + $code = "<!-- Hide script\n$code\n' End script hiding -->" + if $code && $type=~/vbscript/i; push(@result,script({@satts},$code || '')); } @result; @@ -1453,7 +1395,7 @@ END_OF_FUNC 'isindex' => <<'END_OF_FUNC', sub isindex { my($self,@p) = self_or_default(@_); - my($action,@other) = $self->rearrange([ACTION],@p); + my($action,@other) = rearrange([ACTION],@p); $action = qq/ACTION="$action"/ if $action; my($other) = @other ? " @other" : ''; return "<ISINDEX $action$other>"; @@ -1472,7 +1414,7 @@ sub startform { my($self,@p) = self_or_default(@_); my($method,$action,$enctype,@other) = - $self->rearrange([METHOD,ACTION,ENCTYPE],@p); + rearrange([METHOD,ACTION,ENCTYPE],@p); $method = $method || 'POST'; $enctype = $enctype || &URL_ENCODED; @@ -1504,14 +1446,13 @@ END_OF_FUNC 'start_multipart_form' => <<'END_OF_FUNC', sub start_multipart_form { my($self,@p) = self_or_default(@_); - if ($self->use_named_parameters || - (defined($param[0]) && substr($param[0],0,1) eq '-')) { + if (defined($param[0]) && substr($param[0],0,1) eq '-') { my(%p) = @p; $p{'-enctype'}=&MULTIPART; return $self->startform(%p); } else { my($method,$action,@other) = - $self->rearrange([METHOD,ACTION],@p); + rearrange([METHOD,ACTION],@p); return $self->startform($method,$action,&MULTIPART,@other); } } @@ -1523,8 +1464,12 @@ END_OF_FUNC 'endform' => <<'END_OF_FUNC', sub endform { my($self,@p) = self_or_default(@_); + if ( $NOSTICKY ) { + return wantarray ? ("</FORM>") : "\n</FORM>"; + } else { return wantarray ? ($self->get_fields,"</FORM>") : $self->get_fields ."\n</FORM>"; + } } END_OF_FUNC @@ -1542,7 +1487,7 @@ END_OF_FUNC sub _textfield { my($self,$tag,@p) = self_or_default(@_); my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); + rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); my $current = $override ? $default : (defined($self->param($name)) ? $self->param($name) : $default); @@ -1626,7 +1571,7 @@ sub textarea { my($self,@p) = self_or_default(@_); my($name,$default,$rows,$cols,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p); + rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p); my($current)= $override ? $default : (defined($self->param($name)) ? $self->param($name) : $default); @@ -1655,7 +1600,7 @@ END_OF_FUNC sub button { my($self,@p) = self_or_default(@_); - my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL], + my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL], [ONCLICK,SCRIPT]],@p); $label=$self->escapeHTML($label); @@ -1687,12 +1632,12 @@ END_OF_FUNC sub submit { my($self,@p) = self_or_default(@_); - my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p); + my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@p); $label=$self->escapeHTML($label); $value=$self->escapeHTML($value); - my($name) = ' NAME=".submit"'; + my($name) = ' NAME=".submit"' unless $NOSTICKY; $name = qq/ NAME="$label"/ if defined($label); $value = defined($value) ? $value : $label; my($val) = ''; @@ -1713,7 +1658,7 @@ END_OF_FUNC 'reset' => <<'END_OF_FUNC', sub reset { my($self,@p) = self_or_default(@_); - my($label,@other) = $self->rearrange([NAME],@p); + my($label,@other) = rearrange([NAME],@p); $label=$self->escapeHTML($label); my($value) = defined($label) ? qq/ VALUE="$label"/ : ''; my($other) = @other ? " @other" : ''; @@ -1737,7 +1682,7 @@ END_OF_FUNC sub defaults { my($self,@p) = self_or_default(@_); - my($label,@other) = $self->rearrange([[NAME,VALUE]],@p); + my($label,@other) = rearrange([[NAME,VALUE]],@p); $label=$self->escapeHTML($label); $label = $label || "Defaults"; @@ -1775,7 +1720,7 @@ sub checkbox { my($self,@p) = self_or_default(@_); my($name,$checked,$value,$label,$override,@other) = - $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); + rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); $value = defined $value ? $value : 'on'; @@ -1823,7 +1768,7 @@ sub checkbox_group { my($name,$values,$defaults,$linebreak,$labels,$rows,$columns, $rowheaders,$colheaders,$override,$nolabels,@other) = - $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], + rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], LINEBREAK,LABELS,ROWS,[COLUMNS,COLS], ROWHEADERS,COLHEADERS, [OVERRIDE,FORCE],NOLABELS],@p); @@ -1865,11 +1810,20 @@ sub escapeHTML { my ($self,$toencode) = self_or_default(@_); return undef unless defined($toencode); return $toencode if ref($self) && $self->{'dontescape'}; - - $toencode=~s/&/&/g; - $toencode=~s/\"/"/g; - $toencode=~s/>/>/g; - $toencode=~s/</</g; + if (uc $self->{'.charset'} eq 'ISO-8859-1') { + # fix non-compliant bug in IE and Netscape + $toencode =~ s{(.)}{ + if ($1 eq '<') { '<' } + elsif ($1 eq '>') { '>' } + elsif ($1 eq '&') { '&' } + elsif ($1 eq '"') { '"' } + elsif ($1 eq "\x8b") { '‹' } + elsif ($1 eq "\x9b") { '›' } + else { $1 } + }gsex; + } else { + $toencode =~ s/(.)/'&#'.ord($1).';'/gsex; + } return $toencode; } END_OF_FUNC @@ -1911,7 +1865,7 @@ sub _tableize { $result = "<TABLE>"; my($row,$column); unshift(@$colheaders,'') if @$colheaders && @$rowheaders; - $result .= "<TR>" if @$colheaders; + $result .= "<TR>" if @{$colheaders}; foreach (@{$colheaders}) { $result .= "<TH>$_</TH>"; } @@ -1953,7 +1907,7 @@ sub radio_group { my($name,$values,$default,$linebreak,$labels, $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = - $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, + rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, ROWS,[COLUMNS,COLS], ROWHEADERS,COLHEADERS, [OVERRIDE,FORCE],NOLABELS],@p); @@ -2011,7 +1965,7 @@ sub popup_menu { my($self,@p) = self_or_default(@_); my($name,$values,$default,$labels,$override,@other) = - $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p); + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p); my($result,$selected); if (!$override && defined($self->param($name))) { @@ -2065,7 +2019,7 @@ END_OF_FUNC sub scrolling_list { my($self,@p) = self_or_default(@_); my($name,$values,$defaults,$size,$multiple,$labels,$override,@other) - = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], + = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); my($result,@values); @@ -2086,7 +2040,7 @@ sub scrolling_list { $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label=$self->escapeHTML($label); my($value)=$self->escapeHTML($_); - $result .= "<OPTION $selectit VALUE=\"$value\">$label\n"; + $result .= "<OPTION $selectit VALUE=\"$value\">$label</OPTION>\n"; } $result .= "</SELECT>\n"; $self->register_parameter($name); @@ -2112,10 +2066,10 @@ sub hidden { # calling scheme, so we have to special-case (darn) my(@result,@value); my($name,$default,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); + rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); my $do_override = 0; - if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) { + if ( ref($p[0]) || substr($p[0],0,1) eq '-') { @value = ref($default) ? @{$default} : $default; $do_override = $override; } else { @@ -2151,7 +2105,7 @@ sub image_button { my($self,@p) = self_or_default(@_); my($name,$src,$alignment,@other) = - $self->rearrange([NAME,SRC,ALIGN],@p); + rearrange([NAME,SRC,ALIGN],@p); my($align) = $alignment ? " ALIGN=\U$alignment" : ''; my($other) = @other ? " @other" : ''; @@ -2192,7 +2146,7 @@ END_OF_FUNC sub url { my($self,@p) = self_or_default(@_); my ($relative,$absolute,$full,$path_info,$query) = - $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p); + rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p); my $url; $full++ if !($relative || $absolute); @@ -2204,8 +2158,10 @@ sub url { # strip query string substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0; # and path - substr($script_name,$index) = '' if exists($ENV{PATH_INFO}) - and ($index = rindex($script_name,$ENV{PATH_INFO})) >= 0; + if (exists($ENV{PATH_INFO})) { + my $decoded_path = unescape($ENV{PATH_INFO}); + substr($script_name,$index) = '' if ($index = rindex($script_name,$decoded_path)) >= 0; + } } else { $script_name = $self->script_name; } @@ -2231,6 +2187,8 @@ sub url { } $url .= $path if $path_info and defined $path; $url .= "?" . $self->query_string if $query and $self->query_string; + $url = '' unless defined $url; + $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/uc sprintf("%%%02x",ord($1))/eg; return $url; } @@ -2252,7 +2210,7 @@ END_OF_FUNC sub cookie { my($self,@p) = self_or_default(@_); my($name,$value,$path,$domain,$secure,$expires) = - $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); + rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); require CGI::Cookie; @@ -2285,69 +2243,6 @@ sub cookie { } END_OF_FUNC -# This internal routine creates an expires time exactly some number of -# hours from the current time. It incorporates modifications from -# Mark Fisher. -'expire_calc' => <<'END_OF_FUNC', -sub expire_calc { - my($time) = @_; - my(%mult) = ('s'=>1, - 'm'=>60, - 'h'=>60*60, - 'd'=>60*60*24, - 'M'=>60*60*24*30, - 'y'=>60*60*24*365); - # format for time can be in any of the forms... - # "now" -- expire immediately - # "+180s" -- in 180 seconds - # "+2m" -- in 2 minutes - # "+12h" -- in 12 hours - # "+1d" -- in 1 day - # "+3M" -- in 3 months - # "+2y" -- in 2 years - # "-3m" -- 3 minutes ago(!) - # If you don't supply one of these forms, we assume you are - # specifying the date yourself - my($offset); - if (!$time || (lc($time) eq 'now')) { - $offset = 0; - } elsif ($time=~/^\d+/) { - return $time; - } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { - $offset = ($mult{$2} || 1)*$1; - } else { - return $time; - } - return (time+$offset); -} -END_OF_FUNC - -# This internal routine creates date strings suitable for use in -# cookies and HTTP headers. (They differ, unfortunately.) -# Thanks to Mark Fisher for this. -'expires' => <<'END_OF_FUNC', -sub expires { - my($time,$format) = @_; - $format ||= 'http'; - - my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; - my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; - - # pass through preformatted dates for the sake of expire_calc() - $time = expire_calc($time); - return $time unless $time =~ /^\d+$/; - - # make HTTP/cookie date string from GMT'ed time - # (cookies use '-' as date separator, HTTP uses ' ') - my($sc) = ' '; - $sc = '-' if $format eq "cookie"; - my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); - $year += 1900; - return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", - $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); -} -END_OF_FUNC - 'parse_keywordlist' => <<'END_OF_FUNC', sub parse_keywordlist { my($self,$tosplit) = @_; @@ -2361,7 +2256,7 @@ END_OF_FUNC 'param_fetch' => <<'END_OF_FUNC', sub param_fetch { my($self,@p) = self_or_default(@_); - my($name) = $self->rearrange([NAME],@p); + my($name) = rearrange([NAME],@p); unless (exists($self->{$name})) { $self->add_parameter($name); $self->{$name} = []; @@ -2730,6 +2625,17 @@ sub user_name { } END_OF_FUNC +#### Method: nosticky +# Set or return the NOSTICKY global flag +#### +'nosticky' => <<'END_OF_FUNC', +sub nosticky { + my ($self,$param) = self_or_CGI(@_); + $CGI::NOSTICKY = $param if defined($param); + return $CGI::NOSTICKY; +} +END_OF_FUNC + #### Method: nph # Set or return the NPH global flag #### @@ -2757,8 +2663,12 @@ END_OF_FUNC #### 'default_dtd' => <<'END_OF_FUNC', sub default_dtd { - my ($self,$param) = self_or_CGI(@_); - $CGI::DEFAULT_DTD = $param if defined($param); + my ($self,$param,$param2) = self_or_CGI(@_); + if (defined $param2 && defined $param) { + $CGI::DEFAULT_DTD = [ $param, $param2 ]; + } elsif (defined $param) { + $CGI::DEFAULT_DTD = $param; + } return $CGI::DEFAULT_DTD; } END_OF_FUNC @@ -2803,9 +2713,9 @@ END_OF_FUNC sub read_from_cmdline { my($input,@words); my($query_string); - if (@ARGV) { + if ($DEBUG && @ARGV) { @words = @ARGV; - } else { + } elsif ($DEBUG > 1) { require "shellwords.pl"; print STDERR "(offline mode: enter name=value pairs on standard input)\n"; chomp(@lines = <STDIN>); # remove newlines @@ -3010,7 +2920,9 @@ END_OF_FUNC sub new { my($pack,$name,$file,$delete) = @_; require Fcntl unless defined &Fcntl::O_RDWR; - my $ref = \*{'Fh::' . ++$FH . quotemeta($name)}; + my $fv = ('Fh::' . ++$FH . quotemeta($name)); + warn unless *{$fv}; + my $ref = \*{$fv}; sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; unlink($file) if $delete; CORE::delete $Fh::{$FH}; @@ -3073,6 +2985,7 @@ sub new { # Netscape seems to be a little bit unreliable # about providing boundary strings. + my $boundary_read = 0; if ($boundary) { # Under the MIME spec, the boundary consists of the @@ -3089,6 +3002,7 @@ sub new { $length -= length($boundary); chomp($boundary); # remove the CRLF $/ = $old; # restore old line separator + $boundary_read++; } my $self = {LENGTH=>$length, @@ -3104,7 +3018,9 @@ sub new { my $retval = bless $self,ref $package || $package; # Read the preamble and the topmost (boundary) line plus the CRLF. - while ($self->read(0)) { } + unless ($boundary_read) { + while ($self->read(0)) { } + } die "Malformed multipart POST\n" if $self->eof; return $retval; @@ -3118,9 +3034,7 @@ sub readHeader { my($ok) = 0; my($bad) = 0; - if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert! - local($CRLF) = "\015\012"; - } + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS'; do { $self->fillBuffer($FILLUNIT); @@ -3280,17 +3194,18 @@ my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", "C:${SL}temp","${SL}tmp","${SL}temp", - "${vol}${SL}Temporary Items","${SL}sys\$scratch", - "${SL}WWW_ROOT"); + "${vol}${SL}Temporary Items", + "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH"); unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'}; - # + # this feature was supposed to provide per-user tmpfiles, but + # it is problematic. # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX'; # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this # : can generate a 'getpwuid() not implemented' exception, even though # : it's never called. Found under DOS/Win with the DJGPP perl port. # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX. - unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX'; + # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0; foreach (@TEMP) { do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; @@ -3319,7 +3234,7 @@ sub new { last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++)); } # untaint the darn thing - return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!; + return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\]+)$!; $filename = $1; return bless \$filename; } @@ -3479,17 +3394,6 @@ acceptable. In fact, only the first argument needs to begin with a dash. If a dash is present in the first argument, CGI.pm assumes dashes for the subsequent ones. -You don't have to use the hyphen at all if you don't want to. After -creating a CGI object, call the B<use_named_parameters()> method with -a nonzero value. This will tell CGI.pm that you intend to use named -parameters exclusively: - - $query = new CGI; - $query->use_named_parameters(1); - $field = $query->radio_group('name'=>'OS', - 'values'=>['Unix','Windows','Macintosh'], - 'default'=>'Unix'); - Several routines are commonly called with just one argument. In the case of these routines you can provide the single argument without an argument name. header() happens to be one of these routines. In this @@ -3506,7 +3410,7 @@ For example, the param() routine is used to set a CGI parameter to a single or a multi-valued value. The two cases are shown below: $q->param(-name=>'veggie',-value=>'tomato'); - $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']); + $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']); A large number of routines in CGI.pm actually aren't specifically defined in the module, but are generated automatically as needed. @@ -3655,10 +3559,11 @@ parsed keywords can be obtained as an array using the keywords() method. @names = $query->param If the script was invoked with a parameter list -(e.g. "name1=value1&name2=value2&name3=value3"), the param() -method will return the parameter names as a list. If the -script was invoked as an <ISINDEX> script, there will be a -single parameter named 'keywords'. +(e.g. "name1=value1&name2=value2&name3=value3"), the param() method +will return the parameter names as a list. If the script was invoked +as an <ISINDEX> script and contains a string without ampersands +(e.g. "value1+value2+value3") , there will be a single parameter named +"keywords" containing the "+"-delimited keywords. NOTE: As of version 1.5, the array of parameter names returned will be in the same order as they were submitted by the browser. @@ -3679,6 +3584,10 @@ named parameter. If the parameter is multivalued (e.g. from multiple selections in a scrolling list), you can ask to receive an array. Otherwise the method will return a single value. +If a value is not given in the query string, as in the queries +"name1=&name2=" or "name1&name2", it will be returned as an empty +string. This feature is new in 2.63. + =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER: $query->param('foo','an','array','of','values'); @@ -3982,10 +3891,10 @@ you can import. Pragmas, which are always preceded by a hyphen, change the way that CGI.pm functions in various ways. Pragmas, function sets, and individual functions can all be imported in the same use() line. For example, the following use statement imports the -standard set of functions and disables debugging mode (pragma --no_debug): +standard set of functions and enables debugging mode (pragma +-debug): - use CGI qw/:standard -no_debug/; + use CGI qw/:standard -debug/; The current list of pragmas is as follows: @@ -4025,6 +3934,14 @@ the effect of importing the compiled functions into the current namespace. If you want to compile without importing use the compile() method instead (see below). +=item -nosticky + +This makes CGI.pm not generating the hidden fields .submit +and .cgifields. It is very useful if you don't want to +have the hidden fields appear in the querystring in a GET method. +For example, a search script generated this way will have +a very nice url with search parameters for bookmarking. + =item -nph This makes CGI.pm produce a header appropriate for an NPH (no @@ -4043,6 +3960,13 @@ Semicolon-delimited query strings are always accepted, but will not be emitted by self_url() and query_string() unless the -newstyle_urls pragma is specified. +This became the default in version 2.64. + +=item -oldstyle_urls + +Separate the name=value pairs in CGI parameter query strings with +ampersands rather than semicolons. This is no longer the default. + =item -autoload This overrides the autoloader so that any function in your program @@ -4059,16 +3983,17 @@ to the top of your script. This turns off the command-line processing features. If you want to run a CGI.pm script from the command line to produce HTML, and you -don't want it pausing to request CGI parameters from standard input or -the command line, then use this pragma: +don't want it to read CGI parameters from the command line or STDIN, +then use this pragma: use CGI qw(-no_debug :standard); -If you'd like to process the command-line parameters but not standard -input, this should work: +=item -debug - use CGI qw(-no_debug :standard); - restore_parameters(join('&',@ARGV)); +This turns on full debugging. In addition to reading CGI arguments +from the command-line processing, CGI.pm will pause and try to read +arguments from STDIN, producing the message "(offline mode: enter +name=value pairs on standard input)" features. See the section on debugging for more details. @@ -4188,6 +4113,7 @@ pages. -status=>'402 Payment required', -expires=>'+3d', -cookie=>$cookie, + -charset=>'utf-7', -Cost=>'$2.00'); header() returns the Content-type: header. You can provide your own @@ -4230,8 +4156,11 @@ session cookies. The B<-nph> parameter, if set to a true value, will issue the correct headers to work with a NPH (no-parse-header) script. This is important -to use with certain servers, such as Microsoft Internet Explorer, which -expect all their scripts to be NPH. +to use with certain servers that expect all their scripts to be NPH. + +The B<-charset> parameter can be used to control the character set +sent to the browser. If not provided, defaults to ISO-8859-1. As a +side effect, this sets the charset() method as well. =head2 GENERATING A REDIRECTION HEADER @@ -4294,8 +4223,10 @@ different from the current location, as in All relative links will be interpreted relative to this tag. The argument B<-target> allows you to provide a default target frame -for all the links and fill-out forms on the page. See the Netscape -documentation on frames for details of how to manipulate this. +for all the links and fill-out forms on the page. B<This is a +non-standard HTTP feature which only works with Netscape browsers!> +See the Netscape documentation on frames for details of how to +manipulate this. -target=>"answer_window" @@ -4308,10 +4239,10 @@ into a series of header <META> tags that look something like this: <META NAME="keywords" CONTENT="pharaoh secret mummy"> <META NAME="description" CONTENT="copyright 1996 King Tut"> -There is no support for the HTTP-EQUIV type of <META> tag. This is -because you can modify the HTTP header directly with the B<header()> -method. For example, if you want to send the Refresh: header, do it -in the header() method: +There is no direct support for the HTTP-EQUIV type of <META> tag. +This is because you can modify the HTTP header directly with the +B<header()> method. For example, if you want to send the Refresh: +header, do it in the header() method: print $q->header(-Refresh=>'10; URL=http://www.capricorn.com'); @@ -4464,7 +4395,7 @@ This ends an HTML document by printing the </BODY></HTML> tags. =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION: $myself = $query->self_url; - print "<A HREF=$myself>I'm talking to myself.</A>"; + print q(<A HREF="$myself">I'm talking to myself.</A>); self_url() will return a URL, that, when selected, will reinvoke this script with all its state information intact. This is most @@ -4724,6 +4655,49 @@ In addition, start_html(), end_html(), start_form(), end_form(), start_multipart_form() and all the fill-out form tags are special. See their respective sections. +=head2 AUTOESCAPING HTML + +By default, all HTML that is emitted by the form-generating functions +is passed through a function called escapeHTML(): + +=over 4 + +=item $escaped_string = escapeHTML("unescaped string"); + +Escape HTML formatting characters in a string. + +=back + +Provided that you have specified a character set of ISO-8859-1 (the +default), the standard HTML escaping rules will be used. The "<" +character becomes "<", ">" becomes ">", "&" becomes "&", and +the quote character becomes """. In addition, the hexadecimal +0x8b and 0x9b characters, which many windows-based browsers interpret +as the left and right angle-bracket characters, are replaced by their +numeric HTML entities ("‹" and "›"). If you manually change +the charset, either by calling the charset() method explicitly or by +passing a -charset argument to header(), then B<all> characters will +be replaced by their numeric entities, since CGI.pm has no lookup +table for all the possible encodings. + +The automatic escaping does not apply to other shortcuts, such as +h1(). You should call escapeHTML() yourself on untrusted data in +order to protect your pages against nasty tricks that people may enter +into guestbooks, etc.. To change the character set, use charset(). +To turn autoescaping off completely, use autoescape(): + +=over 4 + +=item $charset = charset([$charset]); + +Get or set the current character set. + +=item $flag = autoEscape([$flag]); + +Get or set the value of the autoescape flag. + +=back + =head2 PRETTY-PRINTING HTML By default, all the HTML produced by these functions comes out as one @@ -4769,7 +4743,6 @@ autoEscape() method with a false value immediately after creating the CGI object $query = new CGI; $query->autoEscape(undef); - =head2 CREATING AN ISINDEX TAG print $query->isindex(-action=>$action); @@ -4784,7 +4757,7 @@ default is to process the query with the current script. =head2 STARTING AND ENDING A FORM - print $query->startform(-method=>$method, + print $query->start_form(-method=>$method, -action=>$action, -enctype=>$encoding); <... various form stuff ...> @@ -4792,11 +4765,11 @@ default is to process the query with the current script. -or- - print $query->startform($method,$action,$encoding); + print $query->start_form($method,$action,$encoding); <... various form stuff ...> print $query->endform; -startform() will return a <FORM> tag with the optional method, +start_form() will return a <FORM> tag with the optional method, action and form encoding that you specify. The defaults are: method: POST @@ -4805,10 +4778,13 @@ action and form encoding that you specify. The defaults are: endform() returns the closing </FORM> tag. -Startform()'s enctype argument tells the browser how to package the various +Start_form()'s enctype argument tells the browser how to package the various fields of the form before sending the form to the server. Two values are possible: +B<Note:> This method was previously named startform(), and startform() +is still recognized as an alias. + =over 4 =item B<application/x-www-form-urlencoded> @@ -4834,10 +4810,10 @@ to handle them. =back -For compatibility, the startform() method uses the older form of +For compatibility, the start_form() method uses the older form of encoding by default. If you want to use the newer form of encoding by default, you can call B<start_multipart_form()> instead of -B<startform()>. +B<start_form()>. JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided for use with JavaScript. The -name parameter gives the @@ -4971,9 +4947,9 @@ recognized. See textfield(). filefield() will return a file upload field for Netscape 2.0 browsers. In order to take full advantage of this I<you must use the new multipart encoding scheme> for the form. You can do this either -by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>, +by calling B<start_form()> with an encoding type of B<$CGI::MULTIPART>, or by calling the new method B<start_multipart_form()> instead of -vanilla B<startform()>. +vanilla B<start_form()>. =over 4 @@ -5795,7 +5771,7 @@ details. You can specify the frame to load in the FORM tag itself. With CGI.pm it looks like this: - print $q->startform(-target=>'ResultsWindow'); + print $q->start_form(-target=>'ResultsWindow'); When your script is reinvoked by the form, its output will be loaded into the frame named "ResultsWindow". If one doesn't already exist @@ -5880,12 +5856,11 @@ http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information. =head1 DEBUGGING -If you are running the script -from the command line or in the perl debugger, you can pass the script -a list of keywords or parameter=value pairs on the command line or -from standard input (you don't have to worry about tricking your -script into reading from environment variables). -You can pass keywords like this: +If you are running the script from the command line or in the perl +debugger, you can pass the script a list of keywords or +parameter=value pairs on the command line or from standard input (you +don't have to worry about tricking your script into reading from +environment variables). You can pass keywords like this: your_script.pl keyword1 keyword2 keyword3 @@ -5901,7 +5876,11 @@ or this: your_script.pl name1=value1&name2=value2 -or even as newline-delimited parameters on standard input. +To turn off this feature, use the -no_debug pragma. + +To test the POST method, you may enable full debugging with the -debug +pragma. This will allow you to feed newline-delimited name=value +pairs to the script on standard input. When debugging, you can use quotes and backslashes to escape characters in the familiar shell manner, letting you place @@ -5912,11 +5891,11 @@ pairs: =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS -The dump() method produces a string consisting of all the query's +The Dump() method produces a string consisting of all the query's name/value pairs formatted nicely as a nested list. This is useful for debugging purposes: - print $query->dump + print $query->Dump Produces something that looks like: @@ -6395,7 +6374,7 @@ for suggestions and bug fixes. sub print_prompt { my($query) = @_; - print $query->startform; + print $query->start_form; print "<EM>What's your name?</EM><BR>"; print $query->textfield('name'); print $query->checkbox('Not my real name'); diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm index 90e9552c75..0a5c1218ee 100644 --- a/lib/CGI/Carp.pm +++ b/lib/CGI/Carp.pm @@ -194,14 +194,14 @@ use Carp; BEGIN { $] >= 5.005 - ? eval q#sub ineval { $^S }# - : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#; + ? eval q#sub ineval { defined $^S ? $^S : _longmess() =~ /eval [\{\']/m }# + : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#; $@ and die; } $main::SIG{__WARN__}=\&CGI::Carp::warn; $main::SIG{__DIE__}=\&CGI::Carp::die; -$CGI::Carp::VERSION = '1.14'; +$CGI::Carp::VERSION = '1.16'; $CGI::Carp::CUSTOM_MSG = undef; # fancy import routine detects and handles 'errorWrap' specially. @@ -335,8 +335,7 @@ $outer_message END ; - if ($mod_perl) { - my $r = Apache->request; + if ($mod_perl && (my $r = Apache->request)) { # If bytes have already been sent, then # we print the message out directly. # Otherwise we make a custom error diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm index bd3c3d8875..9e5a14b47b 100644 --- a/lib/CGI/Cookie.pm +++ b/lib/CGI/Cookie.pm @@ -13,9 +13,9 @@ 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.12'; +$CGI::Cookie::VERSION='1.16'; -use CGI qw(-no_debug); +use CGI::Util qw(rearrange unescape escape); use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback'=>1; @@ -63,8 +63,11 @@ sub parse { my(@pairs) = split("; ",$raw_cookie); foreach (@pairs) { my($key,$value) = split("="); - my(@values) = map CGI::unescape($_),split('&',$value); - $key = CGI::unescape($key); + my(@values) = map unescape($_),split('&',$value); + $key = unescape($key); + # Some foreign cookies are not in name=value format, so ignore + # them. + next if !defined($value); # A bug in Netscape can cause several cookies with same name to # appear. The FIRST one in HTTP_COOKIE is the most recent version. $results{$key} ||= $self->new(-name=>$key,-value=>\@values); @@ -77,7 +80,7 @@ sub new { my $class = shift; $class = ref($class) if ref($class); my($name,$value,$path,$domain,$secure,$expires) = - CGI->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_); + rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_); # Pull out our parameters. my @values; @@ -97,7 +100,7 @@ sub new { },$class; # IE requires the path and domain to be present for some reason. - $path = CGI::url(-absolute=>1) unless defined $path; + $path ||= '/'; # however, this breaks networks which use host tables without fully qualified # names, so we comment it out. # $domain = CGI::virtual_host() unless defined $domain; @@ -120,8 +123,8 @@ sub as_string { push(@constant_values,"expires=$expires") if $expires = $self->expires; push(@constant_values,'secure') if $secure = $self->secure; - my($key) = CGI::escape($self->name); - my($cookie) = join("=",$key,join("&",map CGI::escape($_),$self->value)); + my($key) = escape($self->name); + my($cookie) = join("=",$key,join("&",map escape($_),$self->value)); return join("; ",$cookie,@constant_values); } @@ -163,7 +166,7 @@ sub secure { sub expires { my $self = shift; my $expires = shift; - $self->{'expires'} = CGI::expires($expires,'cookie') if defined $expires; + $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires; return $self->{'expires'}; } @@ -252,8 +255,8 @@ against your script's URL before returning the cookie. For example, if you specify the path "/cgi-bin", then the cookie will be returned to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and "/cgi-bin/customer_service/complain.pl", but not to the script -"/cgi-private/site_admin.pl". By default, the path is set to your -script, so that only it will receive the cookie. +"/cgi-private/site_admin.pl". By default, the path is set to "/", so +that all scripts at your site will receive the cookie. =item B<4. secure flag> diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm index 4f2eed4ce9..20173f9acf 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.03'; +$CGI::Pretty::VERSION = '1.04'; $CGI::DefaultClass = __PACKAGE__; $CGI::Pretty::AutoloadClass = 'CGI'; @CGI::Pretty::ISA = qw( CGI ); @@ -62,15 +62,13 @@ sub _make_tag_func { 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]) && \$_[0] eq \$CGI::DefaultClass) || - (ref(\$_[0]) && - (substr(ref(\$_[0]),0,3) eq 'CGI' || - UNIVERSAL::isa(\$_[0],'CGI'))); - + 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); + my(\@attr) = make_attributes(shift); \$attr = " \@attr" if \@attr; } diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm index 80683a2e80..6b8e012a15 100644 --- a/lib/CGI/Push.pm +++ b/lib/CGI/Push.pm @@ -16,8 +16,9 @@ package CGI::Push; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::Push::VERSION='1.01'; +$CGI::Push::VERSION='1.02'; use CGI; +use CGI::Util 'rearrange'; @ISA = ('CGI'); $CGI::DefaultClass = 'CGI::Push'; @@ -37,7 +38,7 @@ sub do_push { my (@header); my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,@other) = - $self->rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p); + rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p); $type = 'text/html' unless $type; $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE'; $delay = 1 unless defined($delay); @@ -53,7 +54,7 @@ sub do_push { push(@o,'-nph'=>1); print $self->header(@o); print "${boundary}$CGI::CRLF"; - + # now we enter a little loop my @contents; while (1) { @@ -143,6 +144,9 @@ in such a way that it will replace what was there beforehand. The technique will work with HTML pages as well as with graphics files, allowing you to create animated GIFs. +Only Netscape Navigator supports server push. Internet Explorer +browsers do not. + =head1 USING CGI::Push CGI::Push adds one new method to the standard CGI suite, do_push(). diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm new file mode 100644 index 0000000000..0a5c48b6f3 --- /dev/null +++ b/lib/CGI/Util.pm @@ -0,0 +1,182 @@ +package CGI::Util; + +use strict; +use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E'; +require Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(rearrange make_attributes unescape escape expires); + +$VERSION = '1.1'; + +$EBCDIC = "\t" ne "\011"; +if ($EBCDIC) { +@A2E = ( + 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, + 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, +240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, +124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, +215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, +121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, +151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, + 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, + 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, + 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, +144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, +100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, +172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, + 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, +140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 + ); +} + +# Smart rearrangement of parameters to allow named parameter +# calling. We do the rearangement if: +# the first parameter begins with a - +sub rearrange { + my($order,@param) = @_; + return () unless @param; + + if (ref($param[0]) eq 'HASH') { + @param = %{$param[0]}; + } else { + return @param + unless (defined($param[0]) && substr($param[0],0,1) eq '-'); + } + + # map parameters into positional indices + my ($i,%pos); + $i = 0; + foreach (@$order) { + foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; } + $i++; + } + + my (@result,%leftover); + $#result = $#$order; # preextend + while (@param) { + my $key = uc(shift(@param)); + $key =~ s/^\-//; + if (exists $pos{$key}) { + $result[$pos{$key}] = shift(@param); + } else { + $leftover{$key} = shift(@param); + } + } + + push (@result,make_attributes(\%leftover)) if %leftover; + @result; +} + +sub make_attributes { + my $attr = shift; + return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; + my $escape = shift || 0; + my(@att); + foreach (keys %{$attr}) { + my($key) = $_; + $key=~s/^\-//; # get rid of initial - if present + $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes + my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_}; + push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/); + } + return @att; +} + +sub simple_escape { + return unless defined (my $toencode = shift); + $toencode =~ s{(.)}{ + if ($1 eq '<') { '<' } + elsif ($1 eq '>') { '>' } + elsif ($1 eq '&') { '&' } + elsif ($1 eq '"') { '"' } + elsif ($1 eq "\x8b") { '‹' } + elsif ($1 eq "\x9b") { '›' } + else { $1 } + }gsex; + $toencode; +} + +# unescape URL-encoded data +sub unescape { + shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass); + my $todecode = shift; + return undef unless defined($todecode); + $todecode =~ tr/+/ /; # pluses become spaces + if ($EBCDIC) { + $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge; + } else { + $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge; + } + return $todecode; +} + +# URL-encode data +sub escape { + shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass); + my $toencode = shift; + return undef unless defined($toencode); + $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; + return $toencode; +} + +# This internal routine creates date strings suitable for use in +# cookies and HTTP headers. (They differ, unfortunately.) +# Thanks to Mark Fisher for this. +sub expires { + my($time,$format) = @_; + $format ||= 'http'; + + my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; + my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; + + # pass through preformatted dates for the sake of expire_calc() + $time = expire_calc($time); + return $time unless $time =~ /^\d+$/; + + # make HTTP/cookie date string from GMT'ed time + # (cookies use '-' as date separator, HTTP uses ' ') + my($sc) = ' '; + $sc = '-' if $format eq "cookie"; + my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); + $year += 1900; + return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", + $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); +} + +# This internal routine creates an expires time exactly some number of +# hours from the current time. It incorporates modifications from +# Mark Fisher. +sub expire_calc { + my($time) = @_; + my(%mult) = ('s'=>1, + 'm'=>60, + 'h'=>60*60, + 'd'=>60*60*24, + 'M'=>60*60*24*30, + 'y'=>60*60*24*365); + # format for time can be in any of the forms... + # "now" -- expire immediately + # "+180s" -- in 180 seconds + # "+2m" -- in 2 minutes + # "+12h" -- in 12 hours + # "+1d" -- in 1 day + # "+3M" -- in 3 months + # "+2y" -- in 2 years + # "-3m" -- 3 minutes ago(!) + # If you don't supply one of these forms, we assume you are + # specifying the date yourself + my($offset); + if (!$time || (lc($time) eq 'now')) { + $offset = 0; + } elsif ($time=~/^\d+/) { + return $time; + } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { + $offset = ($mult{$2} || 1)*$1; + } else { + return $time; + } + return (time+$offset); +} + +1; diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm index 5e3de49418..8cfdcb48f0 100644 --- a/lib/Carp/Heavy.pm +++ b/lib/Carp/Heavy.pm @@ -42,7 +42,7 @@ sub longmess_heavy { # # if the $error error string is newline terminated then it # is copied into $mess. Otherwise, $mess gets set (at the end of - # the 'else {' section below) to one of two things. The first time + # the 'else' section below) to one of two things. The first time # through, it is set to the "$error at $file line $line" message. # $error is then set to 'called' which triggers subsequent loop # iterations to append $sub to $mess before appending the "$error @@ -121,10 +121,7 @@ sub longmess_heavy { # $line" makes sense as "called at $file line $line". $error = "called"; } - # this kludge circumvents die's incorrect handling of NUL - my $msg = \($mess || $error); - $$msg =~ tr/\0//d; - $$msg; + $mess || $error; } @@ -227,9 +224,7 @@ CALLER: } else { # OK! We've got a candidate package. Time to construct the - # relevant error message and return it. die() doesn't like - # to be given NUL characters (which $msg may contain) so we - # remove them first. + # relevant error message and return it. my $msg; $msg = "$error at $file line $line"; if (defined &Thread::tid) { @@ -237,7 +232,6 @@ CALLER: $mess .= " thread $tid" if $tid; } $msg .= "\n"; - $msg =~ tr/\0//d; return $msg; } } diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index b4f2117557..63eddac739 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -5,6 +5,7 @@ package Class::Struct; use 5.005_64; use strict; +use warnings::register; our(@ISA, @EXPORT, $VERSION); use Carp; @@ -167,8 +168,8 @@ sub struct { $cnt = 0; foreach $name (@methods){ if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { - carp "function '$name' already defined, overrides struct accessor method" - if $^W; + warnings::warn "function '$name' already defined, overrides struct accessor method" + if warnings::enabled(); } else { $pre = $pst = $cmt = $sel = ''; diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm index 94b6aa6e78..475f4ff725 100644 --- a/lib/Dumpvalue.pm +++ b/lib/Dumpvalue.pm @@ -227,9 +227,9 @@ sub unwrap { if ($self->{compactDump} && !grep(ref $_, @{$v})) { if ($#$v >= 0) { $short = $sp . "0..$#{$v} " . - join(" ", - map {$self->stringify($_)} @{$v}[0..$tArrayDepth]) - . "$shortmore"; + join(" ", + map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth) + ) . "$shortmore"; } else { $short = $sp . "empty array"; } @@ -238,7 +238,11 @@ sub unwrap { for my $num ($[ .. $tArrayDepth) { return if $DB::signal and $self->{stopDbSignal}; print "$sp$num "; - $self->DumpElem($v->[$num], $s); + if (exists $v->[$num]) { + $self->DumpElem($v->[$num], $s); + } else { + print "empty slot\n"; + } } print "$sp empty array\n" unless @$v; print "$sp$more" if defined $more ; @@ -404,7 +408,8 @@ sub dumpvars { next if @vars && !grep( matchvar($key, $_), @vars ); if ($self->{usageOnly}) { $self->globUsage(\$val, $key) - unless $package eq 'Dumpvalue' and $key eq 'stab'; + if ($package ne 'Dumpvalue' or $key ne 'stab') + and ref(\$val) eq 'GLOB'; } else { $self->dumpglob($package, 0,$key, $val); } diff --git a/lib/English.pm b/lib/English.pm index f6e3ec0021..f38c313beb 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -98,6 +98,8 @@ sub import { *OSNAME *LAST_REGEXP_CODE_RESULT *EXCEPTIONS_BEING_CAUGHT + @LAST_MATCH_START + @LAST_MATCH_END ); # The ground of all being. @ARG is deprecated (5.005 makes @_ lexical) @@ -110,6 +112,8 @@ sub import { *PREMATCH = *` ; *POSTMATCH = *' ; *LAST_PAREN_MATCH = *+ ; + *LAST_MATCH_START = *-{ARRAY} ; + *LAST_MATCH_END = *+{ARRAY} ; # Input. diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 47ce3dcf87..640978a214 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -109,6 +109,7 @@ sub _unix_os2_ext { } elsif (-f ($fullname="$thispth/lib$thislib.$so") && (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){ } elsif (-f ($fullname="$thispth/lib${thislib}_s$Config_libext") + && (! $Config{'archname'} =~ /RM\d\d\d-svr4/) && ($thislib .= "_s") ){ # we must explicitly use _s version } elsif (-f ($fullname="$thispth/lib$thislib$Config_libext")){ } elsif (-f ($fullname="$thispth/$thislib$Config_libext")){ @@ -229,6 +230,10 @@ sub _win32_ext { # add "$Config{installarchlib}/CORE" to default search path push @libpath, "$Config{installarchlib}/CORE"; + if ($VC and exists $ENV{LIB} and $ENV{LIB}) { + push @libpath, split /;/, $ENV{LIB}; + } + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ $thislib = $_; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 4c8da339b8..da2255271f 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -3496,7 +3496,7 @@ MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ -e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \ --e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", shift, ">";' \ +-e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", $$arg=shift, "|", $$arg, ">";' \ -e 'print "=over 4";' \ -e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \ -e 'print "=back";' diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index e08c6791ee..7f40ff7ece 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -684,7 +684,7 @@ MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ -e "install({ @ARGV },'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e "$$\=\"\n\n\";" \ --e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', shift, '>';" \ +-e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', $$arg=shift, '|', $$arg, '>';" \ -e "print '=over 4';" \ -e "while (defined($$key = shift) and defined($$val = shift)) { print '=item *';print 'C<', \"$$key: $$val\", '>'; }" \ -e "print '=back';" diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 38cb2169a3..9906fd5383 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -189,7 +189,7 @@ sub full_setup { AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H - HTMLLIBPODS HTMLSCRIPTPOD IMPORTS + HTMLLIBPODS HTMLSCRIPTPODS IMPORTS INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLHTMLPRIVLIBDIR INSTALLHTMLSCRIPTDIR INSTALLHTMLSITELIBDIR INSTALLMAN1DIR INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 96e1bb44c4..5a71e89636 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -70,6 +70,14 @@ affected is the use of I<target>s by the output C code (see L<perlguts>). This may significantly slow down the generated code, but this is the way B<xsubpp> of 5.005 and earlier operated. +=item B<-noinout> + +Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations. + +=item B<-noargtypes> + +Disable recognition of ANSI-like descriptions of function signature. + =back =head1 ENVIRONMENT @@ -114,7 +122,7 @@ if ($^O eq 'VMS') { $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-s pattern] [-typemap typemap]... file.xs\n"; +$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; # mjn @@ -126,6 +134,10 @@ $WantVersionChk = 1 ; $ProtoUsed = 0 ; $WantLineNumbers = 1 ; $WantOptimize = 1 ; + +my $process_inout = 1; +my $process_argtypes = 1; + SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; @@ -143,6 +155,10 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; + $process_inout = 0, next SWITCH if $flag eq 'noinout'; + $process_inout = 1, next SWITCH if $flag eq 'inout'; + $process_argtypes = 0, next SWITCH if $flag eq 'noargtypes'; + $process_argtypes = 1, next SWITCH if $flag eq 'argtypes'; (print "xsubpp version $XSUBPP_version\n"), exit if $flag eq 'v'; die $usage; @@ -385,9 +401,6 @@ sub CASE_handler { $_ = '' ; } -my $process_inout = 1; -my $process_argtypes = 1; - sub INPUT_handler { for (; !/^$BLOCK_re/o; $_ = shift(@line)) { last if /^\s*NOT_IMPLEMENTED_YET/; @@ -997,6 +1010,11 @@ while (fetch_para()) { ($ret_type) = TidyType($_); $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; + # Allow one-line ANSI-like declaration + unshift @line, $2 + if $process_argtypes + and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; + # a function definition needs at least 2 lines blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH unless @line ; diff --git a/lib/File/Compare.pm b/lib/File/Compare.pm index 8a8afac05f..667e7cb883 100644 --- a/lib/File/Compare.pm +++ b/lib/File/Compare.pm @@ -78,7 +78,7 @@ sub compare { } else { unless (defined($size) && $size > 0) { - $size = $fromsize; + $size = $fromsize || -s TO || 0; $size = 1024 if $size < 512; $size = $Too_Big if $size > $Too_Big; } diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 22a8ab3aed..ac73f1b5eb 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -349,7 +349,7 @@ sub _find_opt { unless ($Is_Dir) { unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { - ($dir,$_) = ('.', $top_item); + ($dir,$_) = ('./', $top_item); } $abs_dir = $dir; @@ -370,9 +370,9 @@ sub _find_opt { warn "Couldn't chdir $abs_dir: $!\n"; next Proc_Top_Item; } - - $name = $abs_dir; - + + $name = $abs_dir . $_; + &$wanted_callback; } diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index 40f5345140..ed26d76a56 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -3,7 +3,7 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '0.8'; +$VERSION = '0.81'; my %module = (MacOS => 'Mac', MSWin32 => 'Win32', diff --git a/lib/File/Spec/Functions.pm b/lib/File/Spec/Functions.pm index 140738f443..0036ac1ded 100644 --- a/lib/File/Spec/Functions.pm +++ b/lib/File/Spec/Functions.pm @@ -3,7 +3,9 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +$VERSION = '1.1'; require Exporter; diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index 959e33d0cf..5315d9220f 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -1,8 +1,11 @@ package File::Spec::Mac; use strict; -use vars qw(@ISA); +use vars qw(@ISA $VERSION); require File::Spec::Unix; + +$VERSION = '1.1'; + @ISA = qw(File::Spec::Unix); =head1 NAME @@ -79,9 +82,9 @@ sub catdir { shift; my @args = @_; my $result = shift @args; - $result =~ s/:\z//; + $result =~ s/:\Z(?!\n)//; foreach (@args) { - s/:\z//; + s/:\Z(?!\n)//; s/^://s; $result .= ":$_"; } @@ -150,7 +153,7 @@ sub rootdir { require Mac::Files; my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, &Mac::Files::kSystemFolderType); - $system =~ s/:.*\z/:/s; + $system =~ s/:.*\Z(?!\n)/:/s; return $system; } @@ -228,7 +231,7 @@ sub splitpath { my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { - ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@s; + ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\Z(?!\n)))?)(.*)@s; } else { $path =~ @@ -242,8 +245,8 @@ sub splitpath { } # Make sure non-empty volumes and directories end in ':' - $volume .= ':' if $volume =~ m@[^:]\z@ ; - $directory .= ':' if $directory =~ m@[^:]\z@ ; + $volume .= ':' if $volume =~ m@[^:]\Z(?!\n)@ ; + $directory .= ':' if $directory =~ m@[^:]\Z(?!\n)@ ; return ($volume,$directory,$file); } @@ -259,7 +262,7 @@ sub splitdir { # check to be sure that there will not be any before handling the # simple case. # - if ( $directories !~ m@:\z@ ) { + if ( $directories !~ m@:\Z(?!\n)@ ) { return split( m@:@, $directories ); } else { @@ -286,11 +289,11 @@ sub catpath { my $segment ; for $segment ( @_ ) { - if ( $result =~ m@[^/]\z@ && $segment =~ m@^[^/]@s ) { + if ( $result =~ m@[^/]\Z(?!\n)@ && $segment =~ m@^[^/]@s ) { $result .= "/$segment" ; } - elsif ( $result =~ m@/\z@ && $segment =~ m@^/@s ) { - $result =~ s@/+\z@/@; + elsif ( $result =~ m@/\Z(?!\n)@ && $segment =~ m@^/@s ) { + $result =~ s@/+\Z(?!\n)@/@; $segment =~ s@^/+@@s; $result .= "$segment" ; } diff --git a/lib/File/Spec/OS2.pm b/lib/File/Spec/OS2.pm index 33370f06c1..20bf8c9dce 100644 --- a/lib/File/Spec/OS2.pm +++ b/lib/File/Spec/OS2.pm @@ -1,8 +1,11 @@ package File::Spec::OS2; use strict; -use vars qw(@ISA); +use vars qw(@ISA $VERSION); require File::Spec::Unix; + +$VERSION = '1.1'; + @ISA = qw(File::Spec::Unix); sub devnull { diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index 0cbc8c7e57..6ca26d74ce 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -1,6 +1,9 @@ package File::Spec::Unix; use strict; +use vars qw($VERSION); + +$VERSION = '1.1'; use Cwd; @@ -35,7 +38,7 @@ sub canonpath { $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx - $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx + $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx return $path; } @@ -146,7 +149,7 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.) sub no_upwards { my $self = shift; - return grep(!/^\.{1,2}\z/s, @_); + return grep(!/^\.{1,2}\Z(?!\n)/s, @_); } =item case_tolerant @@ -223,7 +226,7 @@ sub splitpath { $directory = $path; } else { - $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; + $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs; $directory = $1; $file = $2; } @@ -242,11 +245,13 @@ $directories must be only the directory portion of the path on systems that have the concept of a volume or that have path syntax that differentiates files from directories. -Unlike just splitting the directories on the separator, leading empty and -trailing directory entries can be returned, because these are significant -on some OSs. So, +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSs (e.g. MacOS). + +On Unix, - File::Spec->splitdir( "/a/b/c" ); + File::Spec->splitdir( "/a/b//c/" ); Yields: @@ -261,7 +266,7 @@ sub splitdir { # check to be sure that there will not be any before handling the # simple case. # - if ( $directories !~ m|/\z| ) { + if ( $directories !~ m|/\Z(?!\n)| ) { return split( m|/|, $directories ); } else { diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index a2ac8cac0b..d2be87c660 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -1,8 +1,11 @@ package File::Spec::VMS; use strict; -use vars qw(@ISA); +use vars qw(@ISA $VERSION); require File::Spec::Unix; + +$VERSION = '1.1'; + @ISA = qw(File::Spec::Unix); use Cwd; @@ -56,7 +59,7 @@ sub eliminate_macros { $complex = 1; } } - else { ($macro = unixify($self->{$macro})) =~ s#/\z##; } + else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } $npath = "$head$macro$tail"; } } @@ -86,8 +89,8 @@ sub fixpath { $self = bless {} unless ref $self; my($fixedpath,$prefix,$name); - if ($path =~ m#^\$\([^\)]+\)\z#s || $path =~ m#[/:>\]]#) { - if ($force_path or $path =~ /(?:DIR\)|\])\z/) { + if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { $fixedpath = vmspath($self->eliminate_macros($path)); } else { @@ -97,7 +100,7 @@ sub fixpath { elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { my($vmspre) = $self->eliminate_macros("\$($prefix)"); # is it a dir or just a name? - $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\z/) ? vmspath($vmspre) : ''; + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; $fixedpath = vmspath($fixedpath) if $force_path; } @@ -136,7 +139,7 @@ sub canonpath { my($self,$path) = @_; if ($path =~ m|/|) { # Fake Unix - my $pathify = $path =~ m|/\z|; + my $pathify = $path =~ m|/\Z(?!\n)|; $path = $self->SUPER::canonpath($path); if ($pathify) { return vmspath($path); } else { return vmsify($path); } @@ -169,8 +172,8 @@ sub catdir { if (@dirs) { my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\z//; $sdir =~ s/\.dir\z//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/s; + $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); # Special case for VMS absolute directory specs: these will have had device @@ -181,7 +184,7 @@ sub catdir { } else { if (not defined $dir or not length $dir) { $rslt = ''; } - elsif ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; } + elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } else { $rslt = vmspath($dir); } } return $self->canonpath($rslt); @@ -202,8 +205,8 @@ sub catfile { if (@files) { my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); my $spath = $path; - $spath =~ s/\.dir\z//; - if ($spath =~ /^[^\)\]\/:>]+\)\z/s && basename($file) eq $file) { + $spath =~ s/\.dir\Z(?!\n)//; + if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { $rslt = "$spath$file"; } else { @@ -310,7 +313,7 @@ Checks for VMS directory spec as well as Unix separators. sub file_name_is_absolute { my ($self,$file) = @_; # If it's a logical name, expand it. - $file = $ENV{$file} while $file =~ /^[\w\$\-]+\z/s && $ENV{$file}; + $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; return scalar($file =~ m!^/!s || $file =~ m![<\[][^.\-\]>]! || $file =~ /:[^<\[]/); @@ -341,7 +344,7 @@ sub splitdir { $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal my(@dirs) = split('\.', vmspath($dirspec)); - $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\z//s; + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; @dirs; } @@ -355,7 +358,7 @@ Construct a complete filespec using VMS syntax sub catpath { my($self,$dev,$dir,$file) = @_; if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } - else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } if (length($dev) or length($dir)) { $dir = "[$dir]" unless $dir =~ /[\[<\/]/; $dir = vmspath($dir); @@ -400,17 +403,16 @@ sub abs2rel { } # Split up paths - my ( undef, $path_directories, $path_file ) = - $self->splitpath( $path, 1 ) ; + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; $path_directories = $1 - if $path_directories =~ /^\[(.*)\]\z/s ; + if $path_directories =~ /^\[(.*)\]\Z(?!\n)/s ; - my ( undef, $base_directories, undef ) = - $self->splitpath( $base, 1 ) ; + my $base_directories = ($self->splitpath( $base, 1 ))[1] ; $base_directories = $1 - if $base_directories =~ /^\[(.*)\]\z/s ; + if $base_directories =~ /^\[(.*)\]\Z(?!\n)/s ; # Now, remove all leading components that are the same my @pathchunks = $self->splitdir( $path_directories ); @@ -427,7 +429,7 @@ sub abs2rel { # @basechunks now contains the directories to climb out of, # @pathchunks now has the directories to descend in to. $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ; - $path_directories =~ s{\.\z}{} ; + $path_directories =~ s{\.\Z(?!\n)}{} ; return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; } @@ -458,17 +460,17 @@ sub rel2abs($;$;) { } # Split up paths - my ( undef, $path_directories, $path_file ) = - $self->splitpath( $path ) ; + my ( $path_directories, $path_file ) = + ($self->splitpath( $path ))[1,2] ; - my ( $base_volume, $base_directories, undef ) = + my ( $base_volume, $base_directories ) = $self->splitpath( $base ) ; $path_directories = '' if $path_directories eq '[]' || $path_directories eq '<>'; my $sep = '' ; $sep = '.' - if ( $base_directories =~ m{[^.\]>]\z} && + if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && $path_directories =~ m{^[^.\[<]}s ) ; $base_directories = "$base_directories$sep$path_directories"; diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index aa95fbde36..b8fe37bbdb 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -2,8 +2,11 @@ package File::Spec::Win32; use strict; use Cwd; -use vars qw(@ISA); +use vars qw(@ISA $VERSION); require File::Spec::Unix; + +$VERSION = '1.1'; + @ISA = qw(File::Spec::Unix); =head1 NAME @@ -105,8 +108,8 @@ sub canonpath { $path =~ s|([^\\])\\+|$1\\|g; # xx////xx -> xx/xx $path =~ s|(\\\.)+\\|\\|g; # xx/././xx -> xx/xx $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # ./xx -> xx - $path =~ s|\\\z|| - unless $path =~ m#^([A-Z]:)?\\\z#s; # xx/ -> xx + $path =~ s|\\\Z(?!\n)|| + unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx/ -> xx return $path; } @@ -146,7 +149,7 @@ sub splitpath { (?:\\\\|//)[^\\/]+[\\/][^\\/]+ )? ) - ( (?:.*[\\\\/](?:\.\.?\z)?)? ) + ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) (.*) }xs; $volume = $1; @@ -187,7 +190,7 @@ sub splitdir { # check to be sure that there will not be any before handling the # simple case. # - if ( $directories !~ m|[\\/]\z| ) { + if ( $directories !~ m|[\\/]\Z(?!\n)| ) { return split( m|[\\/]|, $directories ); } else { @@ -216,7 +219,7 @@ sub catpath { # If it's UNC, make sure the glue separator is there, reusing # whatever separator is first in the $volume $volume .= $1 - if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@s && + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && $directory =~ m@^[^\\/]@s ) ; @@ -224,8 +227,8 @@ sub catpath { # If the volume is not just A:, make sure the glue separator is # there, reusing whatever separator is first in the $volume if possible. - if ( $volume !~ m@^[a-zA-Z]:\z@s && - $volume =~ m@[^\\/]\z@ && + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && $file =~ m@[^\\/]@ ) { $volume =~ m@([\\/])@ ; @@ -293,8 +296,7 @@ sub abs2rel { my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ; - my ( undef, $base_directories, undef ) = - $self->splitpath( $base, 1 ) ; + my $base_directories = ($self->splitpath( $base, 1 ))[1] ; # Now, remove all leading components that are the same my @pathchunks = $self->splitdir( $path_directories ); @@ -378,10 +380,10 @@ sub rel2abs($;$;) { $base = $self->canonpath( $base ) ; } - my ( undef, $path_directories, $path_file ) = - $self->splitpath( $path, 1 ) ; + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; - my ( $base_volume, $base_directories, undef ) = + my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ; $path = $self->catpath( diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm new file mode 100644 index 0000000000..736ef3fdb3 --- /dev/null +++ b/lib/File/Temp.pm @@ -0,0 +1,1584 @@ +package File::Temp; + +=head1 NAME + +File::Temp - return name and handle of a temporary file safely + +=head1 SYNOPSIS + + use File::Temp qw/ tempfile tempdir /; + + $dir = tempdir( CLEANUP => 1 ); + ($fh, $filename) = tempfile( DIR => $dir ); + + ($fh, $filename) = tempfile( $template, DIR => $dir); + ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); + + $fh = tempfile(); + +MkTemp family: + + use File::Temp qw/ :mktemp /; + + ($fh, $file) = mkstemp( "tmpfileXXXXX" ); + ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); + + $tmpdir = mkdtemp( $template ); + + $unopened_file = mktemp( $template ); + +POSIX functions: + + use File::Temp qw/ :POSIX /; + + $file = tmpnam(); + $fh = tmpfile(); + + ($fh, $file) = tmpnam(); + ($fh, $file) = tmpfile(); + + +Compatibility functions: + + $unopened_file = File::Temp::tempnam( $dir, $pfx ); + +=begin later + +Objects (NOT YET IMPLEMENTED): + + require File::Temp; + + $fh = new File::Temp($template); + $fname = $fh->filename; + +=end later + +=head1 DESCRIPTION + +C<File::Temp> can be used to create and open temporary files in a safe way. +The tempfile() function can be used to return the name and the open +filehandle of a temporary file. The tempdir() function can +be used to create a temporary directory. + +The security aspect of temporary file creation is emphasized such that +a filehandle and filename are returned together. This helps guarantee that +a race condition can not occur where the temporary file is created by another process +between checking for the existence of the file and its +opening. Additional security levels are provided to check, for +example, that the sticky bit is set on world writable directories. +See L<"safe_level"> for more information. + +For compatibility with popular C library functions, Perl implementations of +the mkstemp() family of functions are provided. These are, mkstemp(), +mkstemps(), mkdtemp() and mktemp(). + +Additionally, implementations of the standard L<POSIX|POSIX> +tmpnam() and tmpfile() functions are provided if required. + +Implementations of mktemp(), tmpnam(), and tempnam() are provided, +but should be used with caution since they return only a filename +that was valid when function was called, so cannot guarantee +that the file will not exist by the time the caller opens the filename. + +=cut + +# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls +# People would like a version on 5.005 so give them what they want :-) +use 5.005; +use strict; +use Carp; +use File::Spec 0.8; +use File::Path qw/ rmtree /; +use Fcntl 1.03; +use Errno qw( EEXIST ENOENT ENOTDIR EINVAL ); + +# use 'our' on v5.6.0 +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG); + +$DEBUG = 0; + +# We are exporting functions + +#require Exporter; +#@ISA = qw/Exporter/; +use base qw/Exporter/; + +# Export list - to allow fine tuning of export table + +@EXPORT_OK = qw{ + tempfile + tempdir + tmpnam + tmpfile + mktemp + mkstemp + mkstemps + mkdtemp + unlink0 + }; + +# Groups of functions for export + +%EXPORT_TAGS = ( + 'POSIX' => [qw/ tmpnam tmpfile /], + 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], + ); + +# add contents of these tags to @EXPORT +Exporter::export_tags('POSIX','mktemp'); + +# Version number + +$VERSION = '0.07'; + +# This is a list of characters that can be used in random filenames + +my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z + a b c d e f g h i j k l m n o p q r s t u v w x y z + 0 1 2 3 4 5 6 7 8 9 _ + /); + +# Maximum number of tries to make a temp file before failing + +use constant MAX_TRIES => 10; + +# Minimum number of X characters that should be in a template +use constant MINX => 4; + +# Default template when no template supplied + +use constant TEMPXXX => 'X' x 10; + +# Constants for the security level + +use constant STANDARD => 0; +use constant MEDIUM => 1; +use constant HIGH => 2; + +# INTERNAL ROUTINES - not to be used outside of package + +# Generic routine for getting a temporary filename +# modelled on OpenBSD _gettemp() in mktemp.c + +# The template must contain X's that are to be replaced +# with the random values + +# Arguments: + +# TEMPLATE - string containing the XXXXX's that is converted +# to a random filename and opened if required + +# Optionally, a hash can also be supplied containing specific options +# "open" => if true open the temp file, else just return the name +# default is 0 +# "mkdir"=> if true, we are creating a temp directory rather than tempfile +# default is 0 +# "suffixlen" => number of characters at end of PATH to be ignored. +# default is 0. +# "open" and "mkdir" can not both be true + +# The default options are equivalent to mktemp(). + +# Returns: +# filehandle - open file handle (if called with doopen=1, else undef) +# temp name - name of the temp file or directory + +# For example: +# ($fh, $name) = _gettemp($template, "open" => 1); + +# for the current version, failures are associated with +# a carp to give the reason whilst debugging + +sub _gettemp { + + croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' + unless scalar(@_) >= 1; + + # Default options + my %options = ( + "open" => 0, + "mkdir" => 0, + "suffixlen" => 0, + ); + + # Read the template + my $template = shift; + if (ref($template)) { + carp "File::Temp::_gettemp: template must not be a reference"; + return (); + } + + # Check that the number of entries on stack are even + if (scalar(@_) % 2 != 0) { + carp "File::Temp::_gettemp: Must have even number of options"; + return (); + } + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Can not open the file and make a directory in a single call + if ($options{"open"} && $options{"mkdir"}) { + carp "File::Temp::_gettemp: doopen and domkdir can not both be true\n"; + return (); + } + + # Find the start of the end of the Xs (position of last X) + # Substr starts from 0 + my $start = length($template) - 1 - $options{"suffixlen"}; + + # Check that we have at least MINX x X (eg 'XXXX") at the end of the string + # (taking suffixlen into account). Any fewer is insecure. + + # Do it using substr - no reason to use a pattern match since + # we know where we are looking and what we are looking for + + if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { + carp "File::Temp::_gettemp: The template must contain at least ". MINX ." 'X' characters\n"; + return (); + } + + # Replace all the X at the end of the substring with a + # random character or just all the XX at the end of a full string. + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # and generate a full path from the template + + my $path = _replace_XX($template, $options{"suffixlen"}); + + + # Split the path into constituent parts - eventually we need to check + # whether the directory exists + # We need to know whether we are making a temp directory + # or a tempfile + + my ($volume, $directories, $file); + my $parent; # parent directory + if ($options{"mkdir"}) { + # There is no filename at the end + ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); + + # The parent is then $directories without the last directory + # Split the directory and put it back together again + my @dirs = File::Spec->splitdir($directories); + + # If @dirs only has one entry that means we are in the current + # directory + if ($#dirs == 0) { + $parent = File::Spec->curdir; + } else { + + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + + } + + } else { + + # Get rid of the last filename (use File::Basename for this?) + ($volume, $directories, $file) = File::Spec->splitpath( $path ); + + # Join up without the file part + $parent = File::Spec->catpath($volume,$directories,''); + + # If $parent is empty replace with curdir + $parent = File::Spec->curdir + unless $directories ne ''; + + } + + # Check that the parent directories exist + # Do this even for the case where we are simply returning a name + # not a file -- no point returning a name that includes a directory + # that does not exist or is not writable + + unless (-d $parent && -w _) { + carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory" + . " or is not writable\n"; + return (); + } + + # Check the stickiness of the directory and chown giveaway if required + # If the directory is world writable the sticky bit + # must be set + + if (File::Temp->safe_level == MEDIUM) { + unless (_is_safe($parent)) { + carp "File::Temp::_gettemp: Parent directory ($parent) is not safe (sticky bit not set when world writable?)"; + return (); + } + } elsif (File::Temp->safe_level == HIGH) { + unless (_is_verysafe($parent)) { + carp "File::Temp::_gettemp: Parent directory ($parent) is not safe (sticky bit not set when world writable?)"; + return (); + } + } + + + # Calculate the flags that we wish to use for the sysopen + # Some of these are not always available + my $openflags; + if ($options{"open"}) { + # Default set + $openflags = O_CREAT | O_EXCL | O_RDWR; + + for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $openflags |= $bit if eval { $bit = &$func(); 1 }; + } + + } + + + # Now try MAX_TRIES time to open the file + for (my $i = 0; $i < MAX_TRIES; $i++) { + + # Try to open the file if requested + if ($options{"open"}) { + my $fh; + + # If we are running before perl5.6.0 we can not auto-vivify + if ($] < 5.006) { + require Symbol; + $fh = &Symbol::gensym; + } + + # Try to make sure this will be marked close-on-exec + # XXX: Win32 doesn't respect this, nor the proper fcntl, + # but may have O_NOINHERIT. This may or may not be in Fcntl. + local $^F = 2; + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Attempt to open the file + if ( sysopen($fh, $path, $openflags, 0600) ) { + + # Reset umask + umask($umask); + + # Opened successfully - return file handle and name + return ($fh, $path); + + } else { + # Reset umask + umask($umask); + + # Error opening file - abort with error + # if the reason was anything but EEXIST + unless ($! == EEXIST) { + carp "File::Temp: Could not create temp file $path: $!"; + return (); + } + + # Loop round for another try + + } + } elsif ($options{"mkdir"}) { + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Open the temp directory + if (mkdir( $path, 0700)) { + # created okay + # Reset umask + umask($umask); + + return undef, $path; + } else { + + # Reset umask + umask($umask); + + # Abort with error if the reason for failure was anything + # except EEXIST + unless ($! == EEXIST) { + carp "File::Temp: Could not create directory $path: $!"; + return (); + } + + # Loop round for another try + + } + + } else { + + # Return true if the file can not be found + # Directory has been checked previously + + return (undef, $path) unless -e $path; + + # Try again until MAX_TRIES + + } + + # Did not successfully open the tempfile/dir + # so try again with a different set of random letters + # No point in trying to increment unless we have only + # 1 X say and the randomness could come up with the same + # file MAX_TRIES in a row. + + # Store current attempt - in principal this implies that the + # 3rd time around the open attempt that the first temp file + # name could be generated again. Probably should store each + # attempt and make sure that none are repeated + + my $original = $path; + my $counter = 0; # Stop infinite loop + my $MAX_GUESS = 50; + + do { + + # Generate new name from original template + $path = _replace_XX($template, $options{"suffixlen"}); + + $counter++; + + } until ($path ne $original || $counter > $MAX_GUESS); + + # Check for out of control looping + if ($counter > $MAX_GUESS) { + carp "Tried to get a new temp name different to the previous value$MAX_GUESS times.\nSomething wrong with template?? ($template)"; + return (); + } + + } + + # If we get here, we have run out of tries + carp "Have exceeded the maximum number of attempts (".MAX_TRIES . + ") to open temp file/dir"; + + return (); + +} + +# Internal routine to return a random character from the +# character list. Does not do an srand() since rand() +# will do one automatically + +# No arguments. Return value is the random character + +sub _randchar { + + $CHARS[ int( rand( $#CHARS ) ) ]; + +} + +# Internal routine to replace the XXXX... with random characters +# This has to be done by _gettemp() every time it fails to +# open a temp file/dir + +# Arguments: $template (the template with XXX), +# $ignore (number of characters at end to ignore) + +# Returns: modified template + +sub _replace_XX { + + croak 'Usage: _replace_XX($template, $ignore)' + unless scalar(@_) == 2; + + my ($path, $ignore) = @_; + + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # Alternatively, could simply set $ignore to length($path)-1 + # Don't want to always use substr when not required though. + + if ($ignore) { + substr($path, 0, - $ignore) =~ s/X(?=X*\z)/_randchar()/ge; + } else { + $path =~ s/X(?=X*\z)/_randchar()/ge; + } + + return $path; +} + +# internal routine to check to see if the directory is safe +# First checks to see if the directory is not owned by the +# current user or root. Then checks to see if anyone else +# can write to the directory and if so, checks to see if +# it has the sticky bit set + +# Will not work on systems that do not support sticky bit + +#Args: directory path to check +# Returns true if the path is safe and false otherwise. +# Returns undef if can not even run stat() on the path + +# This routine based on version written by Tom Christiansen + +# Presumably, by the time we actually attempt to create the +# file or directory in this directory, it may not be safe +# anymore... Have to run _is_safe directly after the open. + +sub _is_safe { + + my $path = shift; + + # Stat path + my @info = stat($path); + return 0 unless scalar(@info); + + # Check to see whether owner is neither superuser (or a system uid) nor me + # Use the real uid from the $< variable + # UID is in [4] + if ( $info[4] > File::Temp->top_system_uid() && $info[4] != $<) { + carp "Directory owned neither by root nor the current user"; + return 0; + } + + # check whether group or other can write file + # use 066 to detect either reading or writing + # use 022 to check writability + # Do it with S_IWOTH and S_IWGRP for portability (maybe) + # mode is in info[2] + if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? + ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? + return 0 unless -d _; # Must be a directory + return 0 unless -k _; # Must be sticky + } + + return 1; +} + +# Internal routine to check whether a directory is safe +# for temp files. Safer than _is_safe since it checks for +# the possibility of chown giveaway and if that is a possibility +# checks each directory in the path to see if it is safe (with _is_safe) + +# If _PC_CHOWN_RESTRICTED is not set, does the full test of each +# directory anyway. + +sub _is_verysafe { + + # Need POSIX - but only want to bother if really necessary due to overhead + require POSIX; + + my $path = shift; + + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined + # and If it is not there do the extensive test + my $chown_restricted; + $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() + if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; + + # If chown_resticted is set to some value we should test it + if (defined $chown_restricted) { + + # Return if the current directory is safe + return _is_safe($path) if POSIX::sysconf( $chown_restricted ); + + } + + # To reach this point either, the _PC_CHOWN_RESTRICTED symbol + # was not avialable or the symbol was there but chown giveaway + # is allowed. Either way, we now have to test the entire tree for + # safety. + + # Convert path to an absolute directory if required + unless (File::Spec->file_name_is_absolute($path)) { + $path = File::Spec->rel2abs($path); + } + + # Split directory into components - assume no file + my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); + + # Slightly less efficient than having a a function in File::Spec + # to chop off the end of a directory or even a function that + # can handle ../ in a directory tree + # Sometimes splitdir() returns a blank at the end + # so we will probably check the bottom directory twice in some cases + my @dirs = File::Spec->splitdir($directories); + + # Concatenate one less directory each time around + foreach my $pos (0.. $#dirs) { + # Get a directory name + my $dir = File::Spec->catpath($volume, + File::Spec->catdir(@dirs[0.. $#dirs - $pos]), + '' + ); + + print "TESTING DIR $dir\n" if $DEBUG; + + # Check the directory + return 0 unless _is_safe($dir); + + } + + return 1; +} + + + +# internal routine to determine whether unlink works on this +# platform for files that are currently open. +# Returns true if we can, false otherwise. + +# Currently WinNT can not unlink an opened file + +sub _can_unlink_opened_file { + + + $^O ne 'MSWin32' ? 1 : 0; + +} + + +# This routine sets up a deferred unlinking of a specified +# filename and filehandle. It is used in the following cases: +# - Called by unlink0 if an opend file can not be unlinked +# - Called by tempfile() if files are to be removed on shutdown +# - Called by tempdir() if directories are to be removed on shutdown + +# Arguments: +# _deferred_unlink( $fh, $fname, $isdir ); +# +# - filehandle (so that it can be expclicitly closed if open +# - filename (the thing we want to remove) +# - isdir (flag to indicate that we are being given a directory) +# [and hence no filehandle] + +# Status is not referred since all the magic is done with END blocks + +sub _deferred_unlink { + + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; + + my ($fh, $fname, $isdir) = @_; + + warn "Setting up deferred removal of $fname\n" + if $DEBUG; + + # If we have a directory, check that it is a directory + if ($isdir) { + + if (-d $fname) { + + # Directory exists so set up END block + # (quoted to preserve lexical variables) + eval q{ + END { + if (-d $fname) { + rmtree($fname, $DEBUG, 1); + } + } + 1; + } || die; + + } else { + carp "Request to remove directory $fname could not be completed since it does not exists!\n"; + } + + + } else { + + if (-f $fname) { + + # dile exists so set up END block + # (quoted to preserve lexical variables) + eval q{ + END { + # close the filehandle without checking its state + # in order to make real sure that this is closed + # if its already closed then I dont care about the answer + # probably a better way to do this + close($fh); + + if (-f $fname) { + unlink $fname + || warn "Error removing $fname"; + } + } + 1; + } || die; + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n"; + } + + + + } + +} + + +=head1 FUNCTIONS + +This section describes the recommended interface for generating +temporary files and directories. + +=over 4 + +=item B<tempfile> + +This is the basic function to generate temporary files. +The behaviour of the file can be changed using various options: + + ($fh, $filename) = tempfile(); + +Create a temporary file in the directory specified for temporary +files, as specified by the tmpdir() function in L<File::Spec>. + + ($fh, $filename) = tempfile($template); + +Create a temporary file in the current directory using the supplied +template. Trailing `X' characters are replaced with random letters to +generate the filename. At least four `X' characters must be present +in the template. + + ($fh, $filename) = tempfile($template, SUFFIX => $suffix) + +Same as previously, except that a suffix is added to the template +after the `X' translation. Useful for ensuring that a temporary +filename has a particular extension when needed by other applications. +But see the WARNING at the end. + + ($fh, $filename) = tempfile($template, DIR => $dir); + +Translates the template as before except that a directory name +is specified. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L<File::Spec>) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( $template, DIR => $dir ); + +If called in scalar context, only the filehandle is returned +and the file will automatically be deleted when closed (see +the description of tmpfile() elsewhere in this document). +This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition +by fumbling with the filename. On systems that can not unlink +an open file (for example, Windows NT) the file is marked for +deletion when the program ends (equivalent to setting UNLINK to 1). + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +=cut + +sub tempfile { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "DIR" => undef, # Directory prefix + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Unlink file on exit + "OPEN" => 1, # Do not open file + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # First decision is whether or not to open the file + if (! $options{"OPEN"}) { + + warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" + if $^W; + + } + + # Construct the template + + # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc + # functions or simply constructing a template and using _gettemp() + # explicitly. Go for the latter + + # First generate a template if not defined and prefix the directory + # If no template must prefix the temp directory + if (defined $template) { + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Now add a suffix + $template .= $options{"SUFFIX"}; + + # Create the file + my ($fh, $path); + croak "Error in tempfile() using $template" + unless (($fh, $path) = _gettemp($template, + "open" => $options{'OPEN'}, + "mkdir"=> 0 , + "suffixlen" => length($options{'SUFFIX'}), + ) ); + + # Set up an exit handler that can do whatever is right for the + # system. Do not check return status since this is all done with + # END blocks + _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; + + # Return + if (wantarray()) { + + if ($options{'OPEN'}) { + return ($fh, $path); + } else { + return (undef, $path); + } + + } else { + + # Unlink the file. It is up to unlink0 to decide what to do with + # this (whether to unlink now or to defer until later) + unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; + + # Return just the filehandle. + return $fh; + } + + +} + +=item B<tempdir> + +This is the recommended interface for creation of temporary directories. +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L<File::Spec|File::Spec>). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, creat the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C<TMPDIR> option is ignored if C<DIR> is set +explicitly. Additionally, C<TMPDIR> is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L<File::Path|File::Path> module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +=cut + +# ' + +sub tempdir { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "CLEANUP" => 0, # Remove directory on exit + "DIR" => '', # Root directory + "TMPDIR" => 0, # Use tempdir with template + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Modify or generate the template + + # Deal with the DIR and TMPDIR options + if (defined $template) { + + # Need to strip directory path if using DIR or TMPDIR + if ($options{'TMPDIR'} || $options{'DIR'}) { + + # Strip parent directory from the filename + # + # There is no filename at the end + my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); + + # Last directory is then our template + $template = (File::Spec->splitdir($directories))[-1]; + + # Prepend the supplied directory or temp dir + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + # Prepend tmpdir + $template = File::Spec->catdir(File::Spec->tmpdir, $template); + + } + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Create the directory + my $tempdir; + croak "Error in tempdir() using $template" + unless ((undef, $tempdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => 0, + ) ); + + # Install exit handler; must be dynamic to get lexical + if ( $options{'CLEANUP'} && -d $tempdir) { + _deferred_unlink(undef, $tempdir, 1); + } + + # Return the dir name + return $tempdir; + +} + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B<mkstemp> + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced +with unique alphanumeric combinations. + +=cut + + + +sub mkstemp { + + croak "Usage: mkstemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($fh, $path); + croak "Error in mkstemp using $template" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => 0, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + + +=item B<mkstemps> + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C<testXXXXXX> and suffix of C<.dat> +would generate a file similar to F<testhGji_w.dat>. + +Returns just the filehandle alone when called in scalar context. + +=cut + +sub mkstemps { + + croak "Usage: mkstemps(template, suffix)" + if scalar(@_) != 2; + + + my $template = shift; + my $suffix = shift; + + $template .= $suffix; + + my ($fh, $path); + croak "Error in mkstemps using $template" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => length($suffix), + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + +=item B<mkdtemp> + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. +Returns undef on failure. + +Directory must be removed by the caller. + +=cut + +#' # for emacs + +sub mkdtemp { + + croak "Usage: mkdtemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($junk, $tmpdir); + croak "Error creating temp directory from template $template\n" + unless (($junk, $tmpdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => 0, + ) ); + + return $tmpdir; + +} + +=item B<mktemp> + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +=cut + +sub mktemp { + + croak "Usage: mktemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($tmpname, $junk); + croak "Error getting name to temp file from template $template\n" + unless (($junk, $tmpname) = _gettemp($template, + "open" => 0, + "mkdir"=> 0 , + "suffixlen" => 0, + ) ); + + return $tmpname; +} + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L<POSIX> +using the mkstemp() from this module. + +Unlike the L<POSIX|POSIX> implementations, the directory used +for the temporary file is not specified in a system include +file (C<P_tmpdir>) but simply depends on the choice of tmpdir() +returned by L<File::Spec|File::Spec>. On some implementations this +location can be set using the C<TMPDIR> environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B<tmpnam> + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L<File::Spec/tmpdir> for information on the choice of temporary +directory for a particular operating system. + +=cut + +sub tmpnam { + + # Retrieve the temporary directory name + my $tmpdir = File::Spec->tmpdir; + + croak "Error temporary directory is not writable" + if $tmpdir eq ''; + + # Use a ten character template and append to tmpdir + my $template = File::Spec->catfile($tmpdir, TEMPXXX); + + if (wantarray() ) { + return mkstemp($template); + } else { + return mktemp($template); + } + +} + +=item B<tmpfile> + +In scalar context, returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +=cut + +sub tmpfile { + + # Simply call tmpnam() in an array context + my ($fh, $file) = tmpnam(); + + # Make sure file is removed when filehandle is closed + unlink0($fh, $file) or croak "Unable to unlink temporary file: $!"; + + return $fh; + +} + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B<tempnam> + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C<sysopen> +with C<O_CREAT | O_EXCL> if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +=cut + +sub tempnam { + + croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; + + my ($dir, $prefix) = @_; + + # Add a string to the prefix + $prefix .= 'XXXXXXXX'; + + # Concatenate the directory to the file + my $template = File::Spec->catfile($dir, $prefix); + + return mktemp($template); + +} + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B<unlink0> + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) or die "Error unlinking file $path safely"; + +Returns false on error. The filehandle is not closed since on some +occasions this is not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends +and good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at the time +the end block is executed since the deferred removal may not have access to +the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C<dev> and C<rdev> fields seem to be different +and also. Also, it seems that the size of the file returned by stat() +does not always agree, with C<stat(FH)> being more accurate than +C<stat(filename)>, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C<unlink0> it). + +=cut + +sub unlink0 { + + croak 'Usage: unlink0(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + warn "Unlinking $path using unlink0\n" + if $DEBUG; + + # Stat the filehandle + my @fh = stat $fh; + + if ($fh[3] > 1 && $^W) { + carp "unlink0: fstat found too many links; SB=@fh"; + } + + # Stat the path + my @path = stat $path; + + unless (@path) { + carp "unlink0: $path is gone already" if $^W; + return; + } + + # this is no longer a file, but may be a directory, or worse + unless (-f _) { + confess "panic: $path is no longer a file: SB=@fh"; + } + + # Do comparison of each member of the array + # On WinNT dev and rdev seem to be different + # depending on whether it is a file or a handle. + # Cannot simply compare all members of the stat return + # Select the ones we can use + my @okstat = (0..$#fh); # Use all by default + if ($^O eq 'MSWin32') { + @okstat = (1,2,3,4,5,7,8,9,10); + } + + # Now compare each entry explicitly by number + for (@okstat) { + print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; + unless ($fh[$_] == $path[$_]) { + warn "Did not match $_ element of stat\n" if $DEBUG; + return 0; + } + } + + # attempt remove the file (does not work on some platforms) + if (_can_unlink_opened_file()) { + # XXX: do *not* call this on a directory; possible race + # resulting in recursive removal + croak "unlink0: $path has become a directory!" if -d $path; + unlink($path) or return 0; + + # Stat the filehandle + @fh = stat $fh; + + print "Link count = $fh[3] \n" if $DEBUG; + + # Make sure that the link count is zero + return ( $fh[3] == 0 ? 1 : 0); + + } else { + _deferred_unlink($fh, $path, 0); + return 1; + } + +} + +=back + +=head1 PACKAGE VARIABLES + +These functions control the global state of the package. + +=over 4 + +=item B<safe_level> + +Controls the lengths to which the module will go to check the safety of the +temporary file or directory before proceeding. +Options are: + +=over 8 + +=item STANDARD + +Do the basic security measures to ensure the directory exists and +is writable, that the umask() is fixed before opening of the file, +that temporary files are opened only if they do not already exist, and +that possible race conditions are avoided. Finally the L<unlink0|"unlink0"> +function is used to remove files safely. + +=item MEDIUM + +In addition to the STANDARD security, the output directory is checked +to make sure that it is owned either by root or the user running the +program. If the directory is writable by group or by other, it is then +checked to make sure that the sticky bit is set. + +Will not work on platforms that do not support the C<-k> test +for sticky bit. + +=item HIGH + +In addition to the MEDIUM security checks, also check for the +possibility of ``chown() giveaway'' using the L<POSIX|POSIX> +sysconf() function. If this is a possibility, each directory in the +path is checked in turn for safeness, recursively walking back to the +root directory. + +For platforms that do not support the L<POSIX|POSIX> +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +assumed that ``chown() giveaway'' is possible and the recursive test +is performed. + +=back + +The level can be changed as follows: + + File::Temp->safe_level( File::Temp::HIGH ); + +The level constants are not exported by the module. + +Currently, you must be running at least perl v5.6.0 in order to +run with MEDIUM or HIGH security. This is simply because the +safety tests use functions from L<Fcntl|Fcntl> that are not +available in older versions of perl. The problem is that the version +number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though +they are different versions..... + +=cut + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n"; + } else { + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + $LEVEL = $level; + } + } + return $LEVEL; + } +} + +=item TopSystemUID + +This is the highest UID on the current system that refers to a root +UID. This is used to make sure that the temporary directory is +owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than +simply by root. + +This is required since on many unix systems C</tmp> is not owned +by root. + +Default is to assume that any UID less than or equal to 10 is a root +UID. + + File::Temp->top_system_uid(10); + my $topid = File::Temp->top_system_uid; + +This value can be adjusted to reduce security checking if required. +The value is only relevant when C<safe_level> is set to MEDIUM or higher. + +=back + +=cut + +{ + my $TopSystemUID = 10; + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + +=head1 WARNING + +For maximum security, endeavour always to avoid ever looking at, +touching, or even imputing the existence of the filename. You do not +know that that filename is connected to the same file as the handle +you have, and attempts to check this can only trigger more race +conditions. It's far more secure to use the filehandle alone and +dispense with the filename altogether. + +If you need to pass the handle to something that expects a filename +then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary +programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl +programs. You will have to clear the close-on-exec bit on that file +descriptor before passing it to another process. + + use Fcntl qw/F_SETFD F_GETFD/; + fcntl($tmpfh, F_SETFD, 0) + or die "Can't clear close-on-exec flag on temp fh: $!\n"; + +=head1 HISTORY + +Originally began life in May 1999 as an XS interface to the system +mkstemp() function. In March 2000, the mkstemp() code was +translated to Perl for total control of the code's +security checking, to ensure the presence of the function regardless of +operating system and to help with portability. + +=head1 SEE ALSO + +L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path> + +See L<File::MkTemp> for a different implementation of temporary +file handling. + +=head1 AUTHOR + +Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> + +Copyright (C) 1999, 2000 Tim Jenness and the UK Particle Physics and +Astronomy Research Council. All Rights Reserved. This program is free +software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +Original Perl implementation loosely based on the OpenBSD C code for +mkstemp(). Thanks to Tom Christiansen for suggesting that this module +should be written and providing ideas for code improvements and +security enhancements. + +=cut + + +1; diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 097e14a7d6..f474c7c4a9 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,12 +2,12 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pl,v 2.22 2000-03-05 21:08:03+01 jv Exp $ +# RCS Status : $Id: GetoptLong.pl,v 2.24 2000-03-14 21:28:52+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Sun Mar 5 21:08:55 2000 -# Update Count : 720 +# Last Modified On: Tue Mar 14 21:28:40 2000 +# Update Count : 721 # Status : Released ################ Copyright ################ @@ -36,7 +36,7 @@ BEGIN { require 5.004; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = "2.21"; + $VERSION = "2.23"; @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -108,12 +108,12 @@ __END__ ################ AutoLoading subroutines ################ -# RCS Status : $Id: GetoptLongAl.pl,v 2.25 2000-03-05 21:08:03+01 jv Exp $ +# RCS Status : $Id: GetoptLongAl.pl,v 2.27 2000-03-17 09:07:26+01 jv Exp $ # Author : Johan Vromans # Created On : Fri Mar 27 11:50:30 1998 # Last Modified By: Johan Vromans -# Last Modified On: Sat Mar 4 16:33:02 2000 -# Update Count : 49 +# Last Modified On: Fri Mar 17 09:00:09 2000 +# Update Count : 55 # Status : Released sub GetOptions { @@ -137,7 +137,7 @@ sub GetOptions { print STDERR ("GetOpt::Long $Getopt::Long::VERSION ", "called from package \"$pkg\".", "\n ", - 'GetOptionsAl $Revision: 2.25 $ ', + 'GetOptionsAl $Revision: 2.27 $ ', "\n ", "ARGV: (@ARGV)", "\n ", @@ -229,17 +229,21 @@ sub GetOptions { if ( $c eq '!' ) { $opctl{"no$_"} = $c; warn ("Ignoring '!' modifier for short option $_\n"); - $c = ''; + $opctl{$_} = $bopctl{$_} = ''; + } + else { + $opctl{$_} = $bopctl{$_} = $c; } - $opctl{$_} = $bopctl{$_} = $c; } else { $_ = lc ($_) if $ignorecase; if ( $c eq '!' ) { $opctl{"no$_"} = $c; - $c = ''; + $opctl{$_} = '' + } + else { + $opctl{$_} = $c; } - $opctl{$_} = $c; } if ( defined $a ) { # Note alias. @@ -419,8 +423,10 @@ sub GetOptions { &{$linkage{$opt}}($opt, $arg); }; print STDERR ("=> die($@)\n") if $debug && $@ ne ''; - if ( $@ =~ /^FINISH\b/ ) { - $goon = 0; + if ( $@ =~ /^!/ ) { + if ( $@ =~ /^!FINISH\b/ ) { + $goon = 0; + } } elsif ( $@ ne '' ) { warn ($@); @@ -487,8 +493,10 @@ sub GetOptions { &$cb ($tryopt); }; print STDERR ("=> die($@)\n") if $debug && $@ ne ''; - if ( $@ =~ /^FINISH\b/ ) { - $goon = 0; + if ( $@ =~ /^!/ ) { + if ( $@ =~ /^!FINISH\b/ ) { + $goon = 0; + } } elsif ( $@ ne '' ) { warn ($@); @@ -1125,10 +1133,10 @@ the desired error message as its argument. GetOptions() will catch the die(), issue the error message, and record that an error result must be returned upon completion. -It is also possible for a user-defined subroutine to preliminary -terminate options processing by calling die() with argument -C<"FINISH">. GetOptions will react as if it encountered a double dash -C<-->. +If the text of the error message starts with an exclamantion mark C<!> +it is interpreted specially by GetOptions(). There is currently one +special command implemented: C<die("!FINISH")> will cause GetOptions() +to stop processing options, as if it encountered a double dash C<-->. =head2 Options with multiple names @@ -1179,7 +1187,11 @@ The argument specification can be The option does not take an argument and may be negated, i.e. prefixed by "no". E.g. C<"foo!"> will allow C<--foo> (a value of 1 will be -assigned) and C<--nofoo> (a value of 0 will be assigned). +assigned) and C<--nofoo> (a value of 0 will be assigned). If the +option has aliases, this applies to the aliases as well. + +Using negation on a single letter option when bundling is in effect is +pointless and will result in a warning. =item + diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm index 580ca39785..64a03a284b 100644 --- a/lib/I18N/Collate.pm +++ b/lib/I18N/Collate.pm @@ -108,6 +108,7 @@ European character set. # --- use POSIX qw(strxfrm LC_COLLATE); +use warnings::register; require Exporter; @@ -123,9 +124,9 @@ cmp collate_cmp sub new { my $new = $_[1]; - if ($^W && $] >= 5.003_06) { + if (warnings::enabled() && $] >= 5.003_06) { unless ($please_use_I18N_Collate_even_if_deprecated) { - warn <<___EOD___; + warnings::warn <<___EOD___; *** WARNING: starting from the Perl version 5.003_06 diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm index 161620ba24..a5a3561794 100644 --- a/lib/IPC/Open2.pm +++ b/lib/IPC/Open2.pm @@ -55,6 +55,13 @@ failure: it just raises an exception matching C</^open2:/>. However, C<exec> failures in the child are not detected. You'll have to trap SIGPIPE yourself. +open2() does not wait for and reap the child process after it exits. +Except for short programs where it's acceptable to let the operating system +take care of this, you need to do this yourself. This is normally as +simple as calling C<waitpid $pid, 0> when you're done with the process. +Failing to do this can result in an accumulation of defunct or "zombie" +processes. See L<perlfunc/waitpid> for more information. + This whole affair is quite dangerous, as you may block forever. It assumes it's going to talk to something like B<bc>, both writing to it and reading from it. This is presumably safe because you diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index d43f1bdb4b..46ebd68cef 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -49,6 +49,13 @@ failure: it just raises an exception matching C</^open3:/>. However, C<exec> failures in the child are not detected. You'll have to trap SIGPIPE yourself. +open3() does not wait for and reap the child process after it exits. +Except for short programs where it's acceptable to let the operating system +take care of this, you need to do this yourself. This is normally as +simple as calling C<waitpid $pid, 0> when you're done with the process. +Failing to do this can result in an accumulation of defunct or "zombie" +processes. See L<perlfunc/waitpid> for more information. + If you try to read from the child's stdout writer and their stderr writer, you'll have problems with blocking, which means you'll want to use select() or the IO::Select, which means you'd best use diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 1a47f4af5e..e5434f48d7 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -5,17 +5,26 @@ # -- Daniel S. Lewart Since Sep 1997 # -require Exporter; package Math::Complex; -use 5.005_64; -use strict; +$VERSION = "1.30"; + +our($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $Inf); + +BEGIN { + my $e = $!; + $Inf = CORE::exp(CORE::exp(30)); # We do want an arithmetic overflow. + $! = $e; # Clear ERANGE. + undef $Inf unless $Inf =~ /^inf(?:inity)?$/i; # Inf INF inf Infinity + $Inf = "Inf" if !defined $Inf || !($Inf > 0); # Desperation. +} -our($VERSION, @ISA, @EXPORT, %EXPORT_TAGS); +use strict; -my ( $i, $ip2, %logn ); +my $i; +my %LOGN; -$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.26 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.\d+)/); +require Exporter; @ISA = qw(Exporter); @@ -49,6 +58,7 @@ use overload '*' => \&multiply, '/' => \÷, '**' => \&power, + '==' => \&numeq, '<=>' => \&spaceship, 'neg' => \&negate, '~' => \&conjugate, @@ -66,7 +76,6 @@ use overload # Package "privates" # -my $package = 'Math::Complex'; # Package name my %DISPLAY_FORMAT = ('style' => 'cartesian', 'polar_pretty_print' => 1); my $eps = 1e-14; # Epsilon @@ -228,6 +237,13 @@ sub i () { } # +# ip2 +# +# Half of i. +# +sub ip2 () { i / 2 } + +# # Attribute access/set routines # @@ -262,7 +278,8 @@ sub update_polar { my ($x, $y) = @{$self->{'cartesian'}}; $self->{p_dirty} = 0; return $self->{'polar'} = [0, 0] if $x == 0 && $y == 0; - return $self->{'polar'} = [CORE::sqrt($x*$x + $y*$y), CORE::atan2($y, $x)]; + return $self->{'polar'} = [CORE::sqrt($x*$x + $y*$y), + CORE::atan2($y, $x)]; } # @@ -342,7 +359,7 @@ sub _divbyzero { if (defined $_[1]) { $mess .= "(Because in the definition of $_[0], the divisor "; - $mess .= "$_[1] " unless ($_[1] eq '0'); + $mess .= "$_[1] " unless ("$_[1]" eq '0'); $mess .= "is 0)\n"; } @@ -416,8 +433,8 @@ sub power { return 1 if $z2 == 0 || $z1 == 1; return 0 if $z1 == 0 && Re($z2) > 0; } - my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) - : CORE::exp($z2 * CORE::log($z1)); + my $w = $inverted ? &exp($z1 * &log($z2)) + : &exp($z2 * &log($z1)); # If both arguments cartesian, return cartesian, else polar. return $z1->{c_dirty} == 0 && (not ref $z2 or $z2->{c_dirty} == 0) ? @@ -440,6 +457,19 @@ sub spaceship { } # +# (numeq) +# +# Computes z1 == z2. +# +# (Required in addition to spaceship() because of NaNs.) +sub numeq { + my ($z1, $z2, $inverted) = @_; + my ($re1, $im1) = ref $z1 ? @{$z1->cartesian} : ($z1, 0); + my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + return $re1 == $re2 && $im1 == $im2 ? 1 : 0; +} + +# # (negate) # # Computes -z. @@ -477,7 +507,13 @@ sub conjugate { # sub abs { my ($z, $rho) = @_; - return $z unless ref $z; + unless (ref $z) { + if (@_ == 2) { + $_[0] = $_[1]; + } else { + return CORE::abs($z); + } + } if (defined $rho) { $z->{'polar'} = [ $rho, ${$z->polar}[1] ]; $z->{p_dirty} = 0; @@ -533,7 +569,8 @@ sub arg { sub sqrt { my ($z) = @_; my ($re, $im) = ref $z ? @{$z->cartesian} : ($z, 0); - return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re) if $im == 0; + return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re) + if $im == 0; my ($r, $t) = @{$z->polar}; return (ref $z)->emake(CORE::sqrt($r), $t/2); } @@ -547,9 +584,12 @@ sub sqrt { # sub cbrt { my ($z) = @_; - return $z < 0 ? -CORE::exp(CORE::log(-$z)/3) : ($z > 0 ? CORE::exp(CORE::log($z)/3): 0) + return $z < 0 ? + -CORE::exp(CORE::log(-$z)/3) : + ($z > 0 ? CORE::exp(CORE::log($z)/3): 0) unless ref $z; my ($r, $t) = @{$z->polar}; + return 0 if $r == 0; return (ref $z)->emake(CORE::exp(CORE::log($r)/3), $t/3); } @@ -559,7 +599,7 @@ sub cbrt { # Die on bad root. # sub _rootbad { - my $mess = "Root $_[0] not defined, root must be positive integer.\n"; + my $mess = "Root $_[0] illegal, root rank must be positive integer.\n"; my @up = caller(1); @@ -581,7 +621,8 @@ sub _rootbad { sub root { my ($z, $n) = @_; _rootbad($n) if ($n < 1 or int($n) != $n); - my ($r, $t) = ref $z ? @{$z->polar} : (CORE::abs($z), $z >= 0 ? 0 : pi); + my ($r, $t) = ref $z ? + @{$z->polar} : (CORE::abs($z), $z >= 0 ? 0 : pi); my @root; my $k; my $theta_inc = pit2 / $n; @@ -723,9 +764,9 @@ sub log10 { sub logn { my ($z, $n) = @_; $z = cplx($z, 0) unless ref $z; - my $logn = $logn{$n}; - $logn = $logn{$n} = CORE::log($n) unless defined $logn; # Cache log(n) - return CORE::log($z) / $logn; + my $logn = $LOGN{$n}; + $logn = $LOGN{$n} = CORE::log($n) unless defined $logn; # Cache log(n) + return &log($z) / $logn; } # @@ -735,11 +776,14 @@ sub logn { # sub cos { my ($z) = @_; + return CORE::cos($z) unless ref $z; my ($x, $y) = @{$z->cartesian}; my $ey = CORE::exp($y); - my $ey_1 = 1 / $ey; - return (ref $z)->make(CORE::cos($x) * ($ey + $ey_1)/2, - CORE::sin($x) * ($ey_1 - $ey)/2); + my $sx = CORE::sin($x); + my $cx = CORE::cos($x); + my $ey_1 = $ey ? 1 / $ey : $Inf; + return (ref $z)->make($cx * ($ey + $ey_1)/2, + $sx * ($ey_1 - $ey)/2); } # @@ -749,11 +793,14 @@ sub cos { # sub sin { my ($z) = @_; + return CORE::sin($z) unless ref $z; my ($x, $y) = @{$z->cartesian}; my $ey = CORE::exp($y); - my $ey_1 = 1 / $ey; - return (ref $z)->make(CORE::sin($x) * ($ey + $ey_1)/2, - CORE::cos($x) * ($ey - $ey_1)/2); + my $sx = CORE::sin($x); + my $cx = CORE::cos($x); + my $ey_1 = $ey ? 1 / $ey : $Inf; + return (ref $z)->make($sx * ($ey + $ey_1)/2, + $cx * ($ey - $ey_1)/2); } # @@ -763,9 +810,9 @@ sub sin { # sub tan { my ($z) = @_; - my $cz = CORE::cos($z); - _divbyzero "tan($z)", "cos($z)" if (CORE::abs($cz) < $eps); - return CORE::sin($z) / $cz; + my $cz = &cos($z); + _divbyzero "tan($z)", "cos($z)" if $cz == 0; + return &sin($z) / $cz; } # @@ -775,7 +822,7 @@ sub tan { # sub sec { my ($z) = @_; - my $cz = CORE::cos($z); + my $cz = &cos($z); _divbyzero "sec($z)", "cos($z)" if ($cz == 0); return 1 / $cz; } @@ -787,7 +834,7 @@ sub sec { # sub csc { my ($z) = @_; - my $sz = CORE::sin($z); + my $sz = &sin($z); _divbyzero "csc($z)", "sin($z)" if ($sz == 0); return 1 / $sz; } @@ -806,9 +853,9 @@ sub cosec { Math::Complex::csc(@_) } # sub cot { my ($z) = @_; - my $sz = CORE::sin($z); + my $sz = &sin($z); _divbyzero "cot($z)", "sin($z)" if ($sz == 0); - return CORE::cos($z) / $sz; + return &cos($z) / $sz; } # @@ -825,8 +872,11 @@ sub cotan { Math::Complex::cot(@_) } # sub acos { my $z = $_[0]; - return CORE::atan2(CORE::sqrt(1-$z*$z), $z) if (! ref $z) && CORE::abs($z) <= 1; - my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + return CORE::atan2(CORE::sqrt(1-$z*$z), $z) + if (! ref $z) && CORE::abs($z) <= 1; + $z = cplx($z, 0) unless ref $z; + my ($x, $y) = @{$z->cartesian}; + return 0 if $x == 1 && $y == 0; my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y); my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y); my $alpha = ($t1 + $t2)/2; @@ -837,7 +887,7 @@ sub acos { my $u = CORE::atan2(CORE::sqrt(1-$beta*$beta), $beta); my $v = CORE::log($alpha + CORE::sqrt($alpha*$alpha-1)); $v = -$v if $y > 0 || ($y == 0 && $x < -1); - return __PACKAGE__->make($u, $v); + return (ref $z)->make($u, $v); } # @@ -847,8 +897,11 @@ sub acos { # sub asin { my $z = $_[0]; - return CORE::atan2($z, CORE::sqrt(1-$z*$z)) if (! ref $z) && CORE::abs($z) <= 1; - my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + return CORE::atan2($z, CORE::sqrt(1-$z*$z)) + if (! ref $z) && CORE::abs($z) <= 1; + $z = cplx($z, 0) unless ref $z; + my ($x, $y) = @{$z->cartesian}; + return 0 if $x == 0 && $y == 0; my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y); my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y); my $alpha = ($t1 + $t2)/2; @@ -859,7 +912,7 @@ sub asin { my $u = CORE::atan2($beta, CORE::sqrt(1-$beta*$beta)); my $v = -CORE::log($alpha + CORE::sqrt($alpha*$alpha-1)); $v = -$v if $y > 0 || ($y == 0 && $x < -1); - return __PACKAGE__->make($u, $v); + return (ref $z)->make($u, $v); } # @@ -870,11 +923,12 @@ sub asin { sub atan { my ($z) = @_; return CORE::atan2($z, 1) unless ref $z; + my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + return 0 if $x == 0 && $y == 0; _divbyzero "atan(i)" if ( $z == i); - _divbyzero "atan(-i)" if (-$z == i); - my $log = CORE::log((i + $z) / (i - $z)); - $ip2 = 0.5 * i unless defined $ip2; - return $ip2 * $log; + _logofzero "atan(-i)" if (-$z == i); # -i is a bad file test... + my $log = &log((i + $z) / (i - $z)); + return ip2 * $log; } # @@ -913,10 +967,11 @@ sub acosec { Math::Complex::acsc(@_) } # sub acot { my ($z) = @_; - _divbyzero "acot(0)" if (CORE::abs($z) < $eps); - return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z) unless ref $z; - _divbyzero "acot(i)" if (CORE::abs($z - i) < $eps); - _logofzero "acot(-i)" if (CORE::abs($z + i) < $eps); + _divbyzero "acot(0)" if $z == 0; + return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z) + unless ref $z; + _divbyzero "acot(i)" if ($z - i == 0); + _logofzero "acot(-i)" if ($z + i == 0); return atan(1 / $z); } @@ -937,11 +992,11 @@ sub cosh { my $ex; unless (ref $z) { $ex = CORE::exp($z); - return ($ex + 1/$ex)/2; + return $ex ? ($ex + 1/$ex)/2 : $Inf; } my ($x, $y) = @{$z->cartesian}; $ex = CORE::exp($x); - my $ex_1 = 1 / $ex; + my $ex_1 = $ex ? 1 / $ex : $Inf; return (ref $z)->make(CORE::cos($y) * ($ex + $ex_1)/2, CORE::sin($y) * ($ex - $ex_1)/2); } @@ -955,12 +1010,15 @@ sub sinh { my ($z) = @_; my $ex; unless (ref $z) { + return 0 if $z == 0; $ex = CORE::exp($z); - return ($ex - 1/$ex)/2; + return $ex ? ($ex - 1/$ex)/2 : "-$Inf"; } my ($x, $y) = @{$z->cartesian}; + my $cy = CORE::cos($y); + my $sy = CORE::sin($y); $ex = CORE::exp($x); - my $ex_1 = 1 / $ex; + my $ex_1 = $ex ? 1 / $ex : $Inf; return (ref $z)->make(CORE::cos($y) * ($ex - $ex_1)/2, CORE::sin($y) * ($ex + $ex_1)/2); } @@ -1016,7 +1074,7 @@ sub cosech { Math::Complex::csch(@_) } sub coth { my ($z) = @_; my $sz = sinh($z); - _divbyzero "coth($z)", "sinh($z)" if ($sz == 0); + _divbyzero "coth($z)", "sinh($z)" if $sz == 0; return cosh($z) / $sz; } @@ -1035,25 +1093,44 @@ sub cotanh { Math::Complex::coth(@_) } sub acosh { my ($z) = @_; unless (ref $z) { - return CORE::log($z + CORE::sqrt($z*$z-1)) if $z >= 1; $z = cplx($z, 0); } my ($re, $im) = @{$z->cartesian}; if ($im == 0) { - return cplx(CORE::log($re + CORE::sqrt($re*$re - 1)), 0) if $re >= 1; - return cplx(0, CORE::atan2(CORE::sqrt(1-$re*$re), $re)) if CORE::abs($re) <= 1; + return CORE::log($re + CORE::sqrt($re*$re - 1)) + if $re >= 1; + return cplx(0, CORE::atan2(CORE::sqrt(1 - $re*$re), $re)) + if CORE::abs($re) < 1; } - return CORE::log($z + CORE::sqrt($z*$z - 1)); + my $t = &sqrt($z * $z - 1) + $z; + # Try Taylor if looking bad (this usually means that + # $z was large negative, therefore the sqrt is really + # close to abs(z), summing that with z...) + $t = 1/(2 * $z) - 1/(8 * $z**3) + 1/(16 * $z**5) - 5/(128 * $z**7) + if $t == 0; + my $u = &log($t); + $u->Im(-$u->Im) if $re < 0 && $im == 0; + return $re < 0 ? -$u : $u; } # # asinh # -# Computes the arc hyperbolic sine asinh(z) = log(z + sqrt(z*z-1)) +# Computes the arc hyperbolic sine asinh(z) = log(z + sqrt(z*z+1)) # sub asinh { my ($z) = @_; - return CORE::log($z + CORE::sqrt($z*$z + 1)); + unless (ref $z) { + my $t = $z + CORE::sqrt($z*$z + 1); + return CORE::log($t) if $t; + } + my $t = &sqrt($z * $z + 1) + $z; + # Try Taylor if looking bad (this usually means that + # $z was large negative, therefore the sqrt is really + # close to abs(z), summing that with z...) + $t = 1/(2 * $z) - 1/(8 * $z**3) + 1/(16 * $z**5) - 5/(128 * $z**7) + if $t == 0; + return &log($t); } # @@ -1067,9 +1144,9 @@ sub atanh { return CORE::log((1 + $z)/(1 - $z))/2 if CORE::abs($z) < 1; $z = cplx($z, 0); } - _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); - _logofzero 'atanh(-1)' if ($z == -1); - return 0.5 * CORE::log((1 + $z) / (1 - $z)); + _divbyzero 'atanh(1)', "1 - $z" if (1 - $z == 0); + _logofzero 'atanh(-1)' if (1 + $z == 0); + return 0.5 * &log((1 + $z) / (1 - $z)); } # @@ -1079,7 +1156,7 @@ sub atanh { # sub asech { my ($z) = @_; - _divbyzero 'asech(0)', $z if ($z == 0); + _divbyzero 'asech(0)', "$z" if ($z == 0); return acosh(1 / $z); } @@ -1108,14 +1185,14 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; - _divbyzero 'acoth(0)' if (CORE::abs($z) < $eps); + _divbyzero 'acoth(0)' if ($z == 0); unless (ref $z) { return CORE::log(($z + 1)/($z - 1))/2 if CORE::abs($z) > 1; $z = cplx($z, 0); } - _divbyzero 'acoth(1)', "$z - 1" if (CORE::abs($z - 1) < $eps); - _logofzero 'acoth(-1)', "1 / $z" if (CORE::abs($z + 1) < $eps); - return CORE::log((1 + $z) / ($z - 1)) / 2; + _divbyzero 'acoth(1)', "$z - 1" if ($z - 1 == 0); + _logofzero 'acoth(-1)', "1 + $z" if (1 + $z == 0); + return &log((1 + $z) / ($z - 1)) / 2; } # @@ -1141,8 +1218,8 @@ sub atan2 { ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); } if ($im2 == 0) { - return cplx(CORE::atan2($re1, $re2), 0) if $im1 == 0; - return cplx(($im1<=>0) * pip2, 0) if $re2 == 0; + return CORE::atan2($re1, $re2) if $im1 == 0; + return ($im1<=>0) * pip2 if $re2 == 0; } my $w = atan($z1/$z2); my ($u, $v) = ref $w ? @{$w->cartesian} : ($w, 0); @@ -1235,67 +1312,58 @@ sub stringify_cartesian { my ($x, $y) = @{$z->cartesian}; my ($re, $im); - $x = int($x + ($x < 0 ? -1 : 1) * $eps) - if int(CORE::abs($x)) != int(CORE::abs($x) + $eps); - $y = int($y + ($y < 0 ? -1 : 1) * $eps) - if int(CORE::abs($y)) != int(CORE::abs($y) + $eps); - - $re = "$x" if CORE::abs($x) >= $eps; - my %format = $z->display_format; my $format = $format{format}; - if ($y == 1) { $im = 'i' } - elsif ($y == -1) { $im = '-i' } - elsif (CORE::abs($y) >= $eps) { - $im = (defined $format ? sprintf($format, $y) : $y) . "i"; + if ($x) { + if ($x =~ /^NaN[QS]?$/i) { + $re = $x; + } else { + if ($x =~ /^-?$Inf$/oi) { + $re = $x; + } else { + $re = defined $format ? sprintf($format, $x) : $x; + } + } + } else { + undef $re; + } + + if ($y) { + if ($y =~ /^(NaN[QS]?)$/i) { + $im = $y; + } else { + if ($y =~ /^-?$Inf$/oi) { + $im = $y; + } else { + $im = + defined $format ? + sprintf($format, $y) : + ($y == 1 ? "" : ($y == -1 ? "-" : $y)); + } + } + $im .= "i"; + } else { + undef $im; } - my $str = ''; - $str = defined $format ? sprintf($format, $re) : $re - if defined $re; + my $str = $re; + if (defined $im) { if ($y < 0) { $str .= $im; - } elsif ($y > 0) { + } elsif ($y > 0 || $im =~ /^NaN[QS]?i$/i) { $str .= "+" if defined $re; $str .= $im; } + } elsif (!defined $re) { + $str = "0"; } return $str; } -# Helper for stringify_polar, a Greatest Common Divisor with a memory. - -sub _gcd { - my ($a, $b) = @_; - - use integer; - - # Loops forever if given negative inputs. - - if ($b and $a > $b) { return gcd($a % $b, $b) } - elsif ($a and $b > $a) { return gcd($b % $a, $a) } - else { return $a ? $a : $b } -} - -my %gcd; - -sub gcd { - my ($a, $b) = @_; - - my $id = "$a $b"; - - unless (exists $gcd{$id}) { - $gcd{$id} = _gcd($a, $b); - $gcd{"$b $a"} = $gcd{$id}; - } - - return $gcd{$id}; -} - # # ->stringify_polar # @@ -1306,74 +1374,50 @@ sub stringify_polar { my ($r, $t) = @{$z->polar}; my $theta; - return '[0,0]' if $r <= $eps; - my %format = $z->display_format; + my $format = $format{format}; - my $nt = $t / pit2; - $nt = ($nt - int($nt)) * pit2; - $nt += pit2 if $nt < 0; # Range [0, 2pi] - - if (CORE::abs($nt) <= $eps) { $theta = 0 } - elsif (CORE::abs(pi-$nt) <= $eps) { $theta = 'pi' } - - if (defined $theta) { - $r = int($r + ($r < 0 ? -1 : 1) * $eps) - if int(CORE::abs($r)) != int(CORE::abs($r) + $eps); - $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) - if ($theta ne 'pi' and - int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps)); - return "\[$r,$theta\]"; + if ($t =~ /^NaN[QS]?$/i || $t =~ /^-?$Inf$/oi) { + $theta = $t; + } elsif ($t == pi) { + $theta = "pi"; + } elsif ($r == 0 || $t == 0) { + $theta = defined $format ? sprintf($format, $t) : $t; } + return "[$r,$theta]" if defined $theta; + # - # Okay, number is not a real. Try to identify pi/n and friends... + # Try to identify pi/n and friends. # - $nt -= pit2 if $nt > pi; - - if ($format{polar_pretty_print} && CORE::abs($nt) >= deg1) { - my ($n, $k, $kpi); - - for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) { - $n = int($kpi / $nt + ($nt > 0 ? 1 : -1) * 0.5); - if (CORE::abs($kpi/$n - $nt) <= $eps) { - $n = CORE::abs($n); - my $gcd = gcd($k, $n); - if ($gcd > 1) { - $k /= $gcd; - $n /= $gcd; - } - next if $n > 360; - $theta = ($nt < 0 ? '-':''). - ($k == 1 ? 'pi':"${k}pi"); - $theta .= '/'.$n if $n > 1; + $t -= int(CORE::abs($t) / pit2) * pit2; + + if ($format{polar_pretty_print}) { + my ($a, $b); + for $a (2..9) { + $b = $t * $a / pi; + if (int($b) == $b) { + $b = $b < 0 ? "-" : "" if CORE::abs($b) == 1; + $theta = "${b}pi/$a"; last; } } } - $theta = $nt unless defined $theta; - - $r = int($r + ($r < 0 ? -1 : 1) * $eps) - if int(CORE::abs($r)) != int(CORE::abs($r) + $eps); - $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) - if ($theta !~ m(^-?\d*pi/\d+$) and - int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps)); - - my $format = $format{format}; if (defined $format) { $r = sprintf($format, $r); - $theta = sprintf($format, $theta); + $theta = sprintf($format, $theta) unless defined $theta; + } else { + $theta = $t unless defined $theta; } - return "\[$r,$theta\]"; + return "[$r,$theta]"; } 1; __END__ -=pod =head1 NAME Math::Complex - complex numbers and associated mathematical functions @@ -1695,7 +1739,7 @@ For instance: print "j = $j\n"; # Prints "j = -0.5+0.866025403784439i" The polar style attempts to emphasize arguments like I<k*pi/n> -(where I<n> is a positive integer and I<k> an integer within [-9,+9]), +(where I<n> is a positive integer and I<k> an integer within [-9, +9]), this is called I<polar pretty-printing>. =head2 CHANGED IN PERL 5.6 @@ -1705,29 +1749,33 @@ C<display_format> object method can now be called using a parameter hash instead of just a one parameter. The old display format style, which can have values C<"cartesian"> or -C<"polar">, can be changed using the C<"style"> parameter. (The one -parameter calling convention also still works.) +C<"polar">, can be changed using the C<"style"> parameter. + + $j->display_format(style => "polar"); + +The one parameter calling convention also still works. + + $j->display_format("polar"); There are two new display parameters. -The first one is C<"format">, which is a sprintf()-style format -string to be used for both parts of the complex number(s). The -default is C<undef>, which corresponds usually (this is somewhat -system-dependent) to C<"%.15g">. You can revert to the default by -setting the format string to C<undef>. +The first one is C<"format">, which is a sprintf()-style format string +to be used for both numeric parts of the complex number(s). The is +somewhat system-dependent but most often it corresponds to C<"%.15g">. +You can revert to the default by setting the C<format> to C<undef>. # the $j from the above example $j->display_format('format' => '%.5f'); print "j = $j\n"; # Prints "j = -0.50000+0.86603i" - $j->display_format('format' => '%.6f'); + $j->display_format('format' => undef); print "j = $j\n"; # Prints "j = -0.5+0.86603i" Notice that this affects also the return values of the C<display_format> methods: in list context the whole parameter hash -will be returned, as opposed to only the style parameter value. If -you want to know the whole truth for a complex number, you must call -both the class method and the object method: +will be returned, as opposed to only the style parameter value. +This is a potential incompatibility with earlier versions if you +have been calling the C<display_format> method in list context. The second new display parameter is C<"polar_pretty_print">, which can be set to true or false, the default being true. See the previous @@ -1791,8 +1839,7 @@ is any integer. Note that because we are operating on approximations of real numbers, these errors can happen when merely `too close' to the singularities -listed above. For example C<tan(2*atan2(1,1)+1e-15)> will die of -division by zero. +listed above. =head1 ERRORS DUE TO INDIGESTIBLE ARGUMENTS diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index 0fd36a9346..ae32677db1 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -1,7 +1,7 @@ ############################################################################# # Pod/Checker.pm -- check pod documents for syntax errors # -# Copyright (C) 1994-1999 by Bradford Appleton. All rights reserved. +# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. @@ -11,7 +11,7 @@ package Pod::Checker; use vars qw($VERSION); $VERSION = 1.098; ## Current version of this package -require 5.004; ## requires this Perl version or later +require 5.005; ## requires this Perl version or later use Pod::ParseUtils; ## for hyperlinks and lists diff --git a/lib/Pod/Find.pm b/lib/Pod/Find.pm index e29c908e16..8de197b71d 100644 --- a/lib/Pod/Find.pm +++ b/lib/Pod/Find.pm @@ -13,8 +13,8 @@ package Pod::Find; use vars qw($VERSION); -$VERSION = 0.11; ## Current version of this package -require 5.004; ## requires this Perl version or later +$VERSION = 0.12; ## Current version of this package +require 5.005; ## requires this Perl version or later ############################################################################# @@ -49,13 +49,15 @@ Only text files containing at least one valid POD command are found. A warning is printed if more than one POD file with the same POD name is found, e.g. F<CPAN.pm> in different directories. This usually -indicates duplicate occurences of modules in the I<@INC> search path. +indicates duplicate occurrences of modules in the I<@INC> search path. The function B<simplify_name> is equivalent to B<basename>, but also -strips Perl-like extensions (.pm, .pl, .pod). +strips Perl-like extensions (.pm, .pl, .pod) and extensions like +F<.bat>, F<.cmd> on Win32 and OS/2, respectively. Note that neither B<pod_find> nor B<simplify_name> are exported by -default so be sure to specify them in the B<use> statement if you need them: +default so be sure to specify them in the B<use> statement if you need +them: use Pod::Find qw(pod_find simplify_name); @@ -86,7 +88,8 @@ B<scriptdir>. This is taken from the local L<Config|Config> module. =item B<-inc> -Search for PODs in the current Perl interpreter's I<@INC> paths. +Search for PODs in the current Perl interpreter's I<@INC> paths. This +automatically considers paths specified in the C<PERL5LIB> environment. =back @@ -104,6 +107,7 @@ L<Pod::Parser>, L<Pod::Checker> use strict; #use diagnostics; use Exporter; +use File::Spec; use File::Find; use Cwd; @@ -144,7 +148,7 @@ sub pod_find require Config; # this code simplifies the POD name for Perl modules: # * remove "site_perl" - # * remove e.g. "i586-linux" + # * remove e.g. "i586-linux" (from 'archname') # * remove e.g. 5.00503 # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) $SIMPLIFY_RX = @@ -158,11 +162,12 @@ sub pod_find my $pwd = cwd(); foreach my $try (@search) { - unless($try =~ m:^/:s) { - # make path absolute - $try = join('/',$pwd,$try); - } - $try =~ s:/\.?(?=/|\z)::; # simplify path + unless(File::Spec->file_name_is_absolute($try)) { + # make path absolute + $try = File::Spec->catfile($pwd,$try); + } + # simplify path + $try = File::Spec->canonpath($try); my $name; if(-f $try) { if($name = _check_and_extract_name($try, $opts{-verbose})) { @@ -170,30 +175,30 @@ sub pod_find } next; } - my $root_rx = qq!^\Q$try\E/!; + my $root_rx = qq!^\Q$try\E/!; File::Find::find( sub { - my $item = $File::Find::name; - if(-d) { - if($dirs_visited{$item}) { - warn "Directory '$item' already seen, skipping.\n" - if($opts{-verbose}); - $File::Find::prune = 1; - return; - } - else { - $dirs_visited{$item} = 1; - } - if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) { + my $item = $File::Find::name; + if(-d) { + if($dirs_visited{$item}) { + warn "Directory '$item' already seen, skipping.\n" + if($opts{-verbose}); + $File::Find::prune = 1; + return; + } + else { + $dirs_visited{$item} = 1; + } + if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) { $File::Find::prune = 1; warn "Perl $] version mismatch on $_, skipping.\n" - if($opts{-verbose}); - } - return; - } + if($opts{-verbose}); + } + return; + } if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { _check_for_duplicates($item, $name, \%names, \%pods); } - }, $try); # end of File::Find::find + }, $try); # end of File::Find::find } chdir $pwd; %pods; @@ -203,8 +208,8 @@ sub _check_for_duplicates { my ($file, $name, $names_ref, $pods_ref) = @_; if($$names_ref{$name}) { warn "Duplicate POD found (shadowing?): $name ($file)\n"; - warn " Already seen in ", - join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; + warn " Already seen in ", + join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; } else { $$names_ref{$name} = 1; @@ -215,15 +220,16 @@ sub _check_for_duplicates { sub _check_and_extract_name { my ($file, $verbose, $root_rx) = @_; - # check extension or executable - unless($file =~ /\.(pod|pm|pl)\z/i || (-f $file && -x _ && -T _)) { + # check extension or executable flag + # this involves testing the .bat extension on Win32! + unless($file =~ /\.(pod|pm|plx?)\z/i || (-f $file && -x _ && -T _)) { return undef; } # check for one line of POD unless(open(POD,"<$file")) { warn "Error: $file is unreadable: $!\n"; - return undef; + return undef; } local $/ = undef; my $pod = <POD>; @@ -245,8 +251,8 @@ sub _check_and_extract_name { else { $name =~ s:^.*/::s; } - $name =~ s/\.(pod|pm|pl)\z//i; - $name =~ s!/+!::!g; + _simplify($name); + $name =~ s!/+!::!g; #/ $name; } @@ -254,10 +260,19 @@ sub _check_and_extract_name { # basename & strip extension sub simplify_name { my ($str) = @_; + # remove all path components $str =~ s:^.*/::s; - $str =~ s:\.p([lm]|od)\z::i; + _simplify($str); $str; } +# internal sub only +sub _simplify { + # strip Perl's own extensions + $_[0] =~ s/\.(pod|pm|plx?)\z//i; + # strip meaningless extensions on Win32 and OS/2 + $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /win|os2/i); +} + 1; diff --git a/lib/Pod/InputObjects.pm b/lib/Pod/InputObjects.pm index 646c00862a..849182bf37 100644 --- a/lib/Pod/InputObjects.pm +++ b/lib/Pod/InputObjects.pm @@ -11,8 +11,8 @@ package Pod::InputObjects; use vars qw($VERSION); -$VERSION = 1.11; ## Current version of this package -require 5.004; ## requires this Perl version or later +$VERSION = 1.12; ## Current version of this package +require 5.005; ## requires this Perl version or later ############################################################################# @@ -522,7 +522,7 @@ sub _set_child2parent_links { my ($self, @children) = @_; ## Make sure any sequences know who their parent is for (@children) { - next if (!ref || ref eq 'SCALAR'); + next unless (length and ref and ref ne 'SCALAR'); if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or UNIVERSAL::can($_, 'nested')) { @@ -922,7 +922,7 @@ sub DESTROY { =head1 SEE ALSO -See L<Pod::Parser>, L<Pod::Select>, and L<Pod::Callbacks>. +See L<Pod::Parser>, L<Pod::Select> =head1 AUTHOR diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm index 898b5442a1..8673ba4795 100644 --- a/lib/Pod/Man.pm +++ b/lib/Pod/Man.pm @@ -1,5 +1,5 @@ # Pod::Man -- Convert POD data to formatted *roff input. -# $Id: Man.pm,v 1.0 2000/03/06 10:16:31 eagle Exp $ +# $Id: Man.pm,v 1.4 2000/04/26 04:03:41 eagle Exp $ # # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu> # @@ -38,7 +38,7 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); # Perl core and too many things could munge CVS magic revision strings. # This number should ideally be the same as the CVS revision in podlators, # however. -$VERSION = 1.00; +$VERSION = 1.04; ############################################################################ @@ -110,7 +110,7 @@ $PREAMBLE = <<'----END OF PREAMBLE----'; .if \nF \{\ . de IX . tm Index:\\$1\t\\n%\t"\\$2" -. . +.. . nr % 0 . rr F .\} @@ -264,13 +264,13 @@ $PREAMBLE = <<'----END OF PREAMBLE----'; # Static helper functions ############################################################################ -# Protect leading quotes and periods against interpretation as commands. A -# leading *roff font escape apparently still leaves a period interpretable -# as a command by some *roff implementations, so look for a period even -# after one of those. +# Protect leading quotes and periods against interpretation as commands. +# Also protect anything starting with a backslash, since it could expand +# or hide something that *roff would interpret as a command. This is +# overkill, but it's much simpler than trying to parse *roff here. sub protect { local $_ = shift; - s{ ^ ( (?: \\f(?:.|\(..) )* [.\'] ) } {\\&$1}xmg; + s/^([.\'\\])/\\&$1/mg; $_; } @@ -396,7 +396,8 @@ sub begin_pod { # */lib/*perl* standard or site_perl module # */*perl*/lib from -D prefix=/opt/perl # */*perl*/ random module hierarchy - # which works. Should be fixed to use File::Spec. + # which works. Should be fixed to use File::Spec. Also handle + # a leading lib/ since that's what ExtUtils::MakeMaker creates. for ($name) { s%//+%/%g; if ( s%^.*?/lib/[^/]*perl[^/]*/%%si @@ -405,6 +406,7 @@ sub begin_pod { s%^(.*-$^O|$^O-.*)/%%so; # arch s%^\d+\.\d+%%s; # version } + s%^lib/%%; s%/%::%g; } } @@ -548,8 +550,11 @@ sub sequence { return bless \ "$tmp", 'Pod::Man::String'; } - # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. - local $_ = $self->collapse ($seq->parse_tree, $command =~ /^[CELX]$/); + # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. C<> + # needs some additional special handling. + my $literal = ($command =~ /^[CELX]$/); + $literal++ if $command eq 'C'; + local $_ = $self->collapse ($seq->parse_tree, $literal); # Handle E<> escapes. if ($command eq 'E') { @@ -574,8 +579,6 @@ sub sequence { } elsif ($command eq 'I') { return bless \ ('\f(IS' . $_ . '\f(IE'), 'Pod::Man::String'; } elsif ($command eq 'C') { - s/-/\\-/g; - s/__/_\\|_/g; return bless \ ('\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"), 'Pod::Man::String'; } @@ -669,11 +672,14 @@ sub cmd_back { # An individual list item. Emit an index entry for anything that's # interesting, but don't emit index entries for things like bullets and # numbers. rofficate bullets too while we're at it (so for nice output, use -# * for your lists rather than o or . or - or some other thing). +# * for your lists rather than o or . or - or some other thing). Newlines +# in an item title are turned into spaces since *roff can't handle them +# embedded. sub cmd_item { my $self = shift; local $_ = $self->parse (@_); s/\s+$//; + s/\s*\n\s*/ /g; my $index; if (/\w/ && !/^\w[.\)]\s*$/) { $index = $_; @@ -825,8 +831,10 @@ sub parse { # text (not call guesswork on it), and returns the concatenation of all of # the text strings in that parse tree. If the literal flag isn't true, # guesswork() will be called on all plain scalars in the parse tree. -# Assumes that everything in the parse tree is either a scalar or a -# reference to a scalar. +# Otherwise, just escape backslashes in the normal case. If collapse is +# being called on a C<> sequence, literal is set to 2, and we do some +# additional cleanup. Assumes that everything in the parse tree is either a +# scalar or a reference to a scalar. sub collapse { my ($self, $ptree, $literal) = @_; if ($literal) { @@ -835,6 +843,8 @@ sub collapse { $$_; } else { s/\\/\\e/g; + s/-/\\-/g if $literal > 1; + s/__/_\\|_/g if $literal > 1; $_; } } $ptree->children); diff --git a/lib/Pod/ParseUtils.pm b/lib/Pod/ParseUtils.pm index 00f516e99c..2cb8cdcd3b 100644 --- a/lib/Pod/ParseUtils.pm +++ b/lib/Pod/ParseUtils.pm @@ -11,7 +11,7 @@ package Pod::ParseUtils; use vars qw($VERSION); $VERSION = 0.2; ## Current version of this package -require 5.004; ## requires this Perl version or later +require 5.005; ## requires this Perl version or later =head1 NAME diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm index 88d9aa7a8f..48fc198ded 100644 --- a/lib/Pod/Parser.pm +++ b/lib/Pod/Parser.pm @@ -10,8 +10,8 @@ package Pod::Parser; use vars qw($VERSION); -$VERSION = 1.11; ## Current version of this package -require 5.004; ## requires this Perl version or later +$VERSION = 1.12; ## Current version of this package +require 5.005; ## requires this Perl version or later ############################################################################# @@ -71,7 +71,7 @@ Pod::Parser - base class for creating POD filters and translators =head1 REQUIRES -perl5.004, Pod::InputObjects, Exporter, Carp +perl5.005, Pod::InputObjects, Exporter, Symbol, Carp =head1 EXPORTS @@ -206,6 +206,12 @@ use Pod::InputObjects; use Carp; use Exporter; require VMS::Filespec if $^O eq 'VMS'; +BEGIN { + if ($] < 5.6) { + require Symbol; + import Symbol; + } +} @ISA = qw(Exporter); ## These "variables" are used as local "glob aliases" for performance @@ -1146,7 +1152,7 @@ sub parse_from_file { my $self = shift; my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); my ($infile, $outfile) = @_; - my ($in_fh, $out_fh); + my ($in_fh, $out_fh) = (gensym, gensym) if ($] < 5.6); my ($close_input, $close_output) = (0, 0); local *myData = $self; local $_; @@ -1197,12 +1203,13 @@ sub parse_from_file { elsif (ref $outfile) { ## Must be a filehandle-ref (or else assume its a ref to an ## object that supports the common IO write operations). - $myData{_OUTFILE} = ${$outfile};; + $myData{_OUTFILE} = ${$outfile}; $out_fh = $outfile; } else { ## We have a filename, open it for writing $myData{_OUTFILE} = $outfile; + (-d $outfile) and croak "$outfile is a directory, not POD input!\n"; open($out_fh, "> $outfile") or croak "Can't open $outfile for writing: $!\n"; $close_output = 1; diff --git a/lib/Pod/Select.pm b/lib/Pod/Select.pm index 53e27e513a..5dd1595107 100644 --- a/lib/Pod/Select.pm +++ b/lib/Pod/Select.pm @@ -10,8 +10,8 @@ package Pod::Select; use vars qw($VERSION); -$VERSION = 1.11; ## Current version of this package -require 5.004; ## requires this Perl version or later +$VERSION = 1.12; ## Current version of this package +require 5.005; ## requires this Perl version or later ############################################################################# @@ -62,7 +62,7 @@ or =head1 REQUIRES -perl5.004, Pod::Parser, Exporter, Carp +perl5.005, Pod::Parser, Exporter, Carp =head1 EXPORTS diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm index d93e5a4b71..f5c1e3d0cf 100644 --- a/lib/Pod/Text.pm +++ b/lib/Pod/Text.pm @@ -1,7 +1,7 @@ # Pod::Text -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 2.3 1999/10/07 09:41:57 eagle Exp $ +# $Id: Text.pm,v 2.4 2000/03/17 00:17:08 eagle Exp $ # -# Copyright 1999 by Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu> # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. @@ -33,7 +33,11 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); # We have to export pod2text for backward compatibility. @EXPORT = qw(pod2text); -($VERSION = (split (' ', q$Revision: 2.3 $ ))[1]) =~ s/\.(\d)$/.0$1/; +# Don't use the CVS revision as the version, since this module is also in +# Perl core and too many things could munge CVS magic revision strings. +# This number should ideally be the same as the CVS revision in podlators, +# however. +$VERSION = 2.04; ############################################################################ @@ -43,7 +47,7 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); # This table is taken near verbatim from Pod::PlainText in Pod::Parser, # which got it near verbatim from the original Pod::Text. It is therefore # credited to Tom Christiansen, and I'm glad I didn't have to write it. :) -# "iexcl" to "divide" added by Tim Jenness +# "iexcl" to "divide" added by Tim Jenness. %ESCAPES = ( 'amp' => '&', # ampersand 'lt' => '<', # left chevron, less-than @@ -113,42 +117,42 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); "yacute" => "\xFD", # small y, acute accent "yuml" => "\xFF", # small y, dieresis or umlaut mark - "lchevron" => "\xAB", # left chevron (double less than) laquo - "rchevron" => "\xBB", # right chevron (double greater than) raquo - - "iexcl" => "\xA1", # inverted exclamation mark - "cent" => "\xA2", # cent sign - "pound" => "\xA3", # (UK) pound sign - "curren" => "\xA4", # currency sign - "yen" => "\xA5", # yen sign - "brvbar" => "\xA6", # broken vertical bar - "sect" => "\xA7", # section sign - "uml" => "\xA8", # diaresis - "copy" => "\xA9", # Copyright symbol - "ordf" => "\xAA", # feminine ordinal indicator - "laquo" => "\xAB", # left pointing double angle quotation mark - "not" => "\xAC", # not sign - "shy" => "\xAD", # soft hyphen - "reg" => "\xAE", # registered trademark - "macr" => "\xAF", # macron, overline - "deg" => "\xB0", # degree sign - "plusmn" => "\xB1", # plus-minus sign - "sup2" => "\xB2", # superscript 2 - "sup3" => "\xB3", # superscript 3 - "acute" => "\xB4", # acute accent - "micro" => "\xB5", # micro sign - "para" => "\xB6", # pilcrow sign = paragraph sign - "middot" => "\xB7", # middle dot = Georgian comma - "cedil" => "\xB8", # cedilla - "sup1" => "\xB9", # superscript 1 - "ordm" => "\xBA", # masculine ordinal indicator - "raquo" => "\xBB", # right pointing double angle quotation mark - "frac14" => "\xBC", # vulgar fraction one quarter - "frac12" => "\xBD", # vulgar fraction one half - "frac34" => "\xBE", # vulgar fraction three quarters - "iquest" => "\xBF", # inverted question mark - "times" => "\xD7", # multiplication sign - "divide" => "\xF7", # division sign + "laquo" => "\xAB", # left pointing double angle quotation mark + "lchevron" => "\xAB", # synonym (backwards compatibility) + "raquo" => "\xBB", # right pointing double angle quotation mark + "rchevron" => "\xBB", # synonym (backwards compatibility) + + "iexcl" => "\xA1", # inverted exclamation mark + "cent" => "\xA2", # cent sign + "pound" => "\xA3", # (UK) pound sign + "curren" => "\xA4", # currency sign + "yen" => "\xA5", # yen sign + "brvbar" => "\xA6", # broken vertical bar + "sect" => "\xA7", # section sign + "uml" => "\xA8", # diaresis + "copy" => "\xA9", # Copyright symbol + "ordf" => "\xAA", # feminine ordinal indicator + "not" => "\xAC", # not sign + "shy" => "\xAD", # soft hyphen + "reg" => "\xAE", # registered trademark + "macr" => "\xAF", # macron, overline + "deg" => "\xB0", # degree sign + "plusmn" => "\xB1", # plus-minus sign + "sup2" => "\xB2", # superscript 2 + "sup3" => "\xB3", # superscript 3 + "acute" => "\xB4", # acute accent + "micro" => "\xB5", # micro sign + "para" => "\xB6", # pilcrow sign = paragraph sign + "middot" => "\xB7", # middle dot = Georgian comma + "cedil" => "\xB8", # cedilla + "sup1" => "\xB9", # superscript 1 + "ordm" => "\xBA", # masculine ordinal indicator + "frac14" => "\xBC", # vulgar fraction one quarter + "frac12" => "\xBD", # vulgar fraction one half + "frac34" => "\xBE", # vulgar fraction three quarters + "iquest" => "\xBF", # inverted question mark + "times" => "\xD7", # multiplication sign + "divide" => "\xF7", # division sign ); diff --git a/lib/Pod/Usage.pm b/lib/Pod/Usage.pm index b8abe7d41b..aa8f712dcf 100644 --- a/lib/Pod/Usage.pm +++ b/lib/Pod/Usage.pm @@ -10,8 +10,8 @@ package Pod::Usage; use vars qw($VERSION); -$VERSION = 1.11; ## Current version of this package -require 5.004; ## requires this Perl version or later +$VERSION = 1.12; ## Current version of this package +require 5.005; ## requires this Perl version or later =head1 NAME diff --git a/lib/Text/Abbrev.pm b/lib/Text/Abbrev.pm index ae6797c81a..d4f12d0b99 100644 --- a/lib/Text/Abbrev.pm +++ b/lib/Text/Abbrev.pm @@ -1,5 +1,5 @@ package Text::Abbrev; -require 5.000; +require 5.005; # Probably works on earlier versions too. require Exporter; =head1 NAME @@ -15,7 +15,7 @@ abbrev - create an abbreviation table from a list =head1 DESCRIPTION Stores all unambiguous truncations of each element of LIST -as keys key in the associative array referenced to by C<$hashref>. +as keys in the associative array referenced by C<$hashref>. The values are the original list elements. =head1 EXAMPLE @@ -34,54 +34,48 @@ The values are the original list elements. @EXPORT = qw(abbrev); # Usage: -# &abbrev(*foo,LIST); +# abbrev \%foo, LIST; # ... # $long = $foo{$short}; sub abbrev { - my (%domain); - my ($name, $ref, $glob); + my ($word, $hashref, $glob, %table, $returnvoid); if (ref($_[0])) { # hash reference preferably - $ref = shift; - } elsif ($_[0] =~ /^\*/) { # looks like a glob (deprecated) - $glob = shift; - } - my @cmp = @_; - - foreach $name (@_) { - my @extra = split(//,$name); - my $abbrev = shift(@extra); - my $len = 1; - my $cmp; - WORD: foreach $cmp (@cmp) { - next if $cmp eq $name; - while (substr($cmp,0,$len) eq $abbrev) { - last WORD unless @extra; - $abbrev .= shift(@extra); - ++$len; + $hashref = shift; + $returnvoid = 1; + } elsif (ref \$_[0] eq 'GLOB') { # is actually a glob (deprecated) + $hashref = \%{shift()}; + $returnvoid = 1; + } + %{$hashref} = (); + + WORD: foreach $word (@_) { + for (my $len = (length $word) - 1; $len > 0; --$len) { + my $abbrev = substr($word,0,$len); + my $seen = ++$table{$abbrev}; + if ($seen == 1) { # We're the first word so far to have + # this abbreviation. + $hashref->{$abbrev} = $word; + } elsif ($seen == 2) { # We're the second word to have this + # abbreviation, so we can't use it. + delete $hashref->{$abbrev}; + } else { # We're the third word to have this + # abbreviation, so skip to the next word. + next WORD; } } - $domain{$abbrev} = $name; - while (@extra) { - $abbrev .= shift(@extra); - $domain{$abbrev} = $name; - } } - if ($ref) { - %$ref = %domain; - return; - } elsif ($glob) { # old style - local (*hash) = $glob; - %hash = %domain; - return; + # Non-abbreviations always get entered, even if they aren't unique + foreach $word (@_) { + $hashref->{$word} = $word; } + return if $returnvoid; if (wantarray) { - %domain; + %{$hashref}; } else { - \%domain; + $hashref; } } 1; - diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm index cbac73535d..588ecead89 100644 --- a/lib/Tie/Handle.pm +++ b/lib/Tie/Handle.pm @@ -108,6 +108,7 @@ The L<perltie> section contains an example of tying handles. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -119,8 +120,8 @@ sub new { sub TIEHANDLE { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" + if warnings::enabled(); $pkg->new(@_); } else { diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 928b798e45..c6ec3d4f5c 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -102,6 +102,7 @@ good working examples. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -113,8 +114,8 @@ sub new { sub TIEHASH { my $pkg = shift; if (defined &{"${pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" + if warnings::enabled(); $pkg->new(@_); } else { diff --git a/lib/Tie/Scalar.pm b/lib/Tie/Scalar.pm index 1e2caee379..0c6759006f 100644 --- a/lib/Tie/Scalar.pm +++ b/lib/Tie/Scalar.pm @@ -79,6 +79,7 @@ process IDs with priority. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -90,8 +91,8 @@ sub new { sub TIESCALAR { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" + if warnings::enabled(); $pkg->new(@_); } else { diff --git a/lib/User/pwent.pm b/lib/User/pwent.pm index 39bfea4fe0..8c059265c3 100644 --- a/lib/User/pwent.pm +++ b/lib/User/pwent.pm @@ -1,51 +1,179 @@ package User::pwent; + +use 5.006; + use strict; +use warnings; + +use Config; +use Carp; -use 5.005_64; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -BEGIN { +BEGIN { use Exporter (); @EXPORT = qw(getpwent getpwuid getpwnam getpw); @EXPORT_OK = qw( - $pw_name $pw_passwd $pw_uid - $pw_gid $pw_quota $pw_comment - $pw_gecos $pw_dir $pw_shell - ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + pw_has + + $pw_name $pw_passwd $pw_uid $pw_gid + $pw_gecos $pw_dir $pw_shell + $pw_expire $pw_change $pw_class + $pw_age + $pw_quota $pw_comment + $pw_expire + + ); + %EXPORT_TAGS = ( + FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ], + ALL => [ @EXPORT, @EXPORT_OK ], + ); } -use vars @EXPORT_OK; +use vars grep /^\$pw_/, @EXPORT_OK; + +# +# XXX: these mean somebody hacked this module's source +# without understanding the underlying assumptions. +# +my $IE = "[INTERNAL ERROR]"; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } use Class::Struct qw(struct); struct 'User::pwent' => [ - name => '$', - passwd => '$', - uid => '$', - gid => '$', - quota => '$', - comment => '$', - gecos => '$', - dir => '$', - shell => '$', + name => '$', # pwent[0] + passwd => '$', # pwent[1] + uid => '$', # pwent[2] + gid => '$', # pwent[3] + + # you'll only have one/none of these three + change => '$', # pwent[4] + age => '$', # pwent[4] + quota => '$', # pwent[4] + + # you'll only have one/none of these two + comment => '$', # pwent[5] + class => '$', # pwent[5] + + # you might not have this one + gecos => '$', # pwent[6] + + dir => '$', # pwent[7] + shell => '$', # pwent[8] + + # you might not have this one + expire => '$', # pwent[9] + ]; -sub populate (@) { + +# init our groks hash to be true if the built platform knew how +# to do each struct pwd field that perl can ever under any circumstances +# know about. we do not use /^pw_?/, but just the tails. +sub _feature_init { + our %Groks; # whether build system knew how to do this feature + for my $feep ( qw{ + pwage pwchange pwclass pwcomment + pwexpire pwgecos pwpasswd pwquota + } + ) + { + my $short = $feep =~ /^pw(.*)/ + ? $1 + : do { + # not cluck, as we know we called ourselves, + # and a confession is probably imminent anyway + warn("$IE $feep is a funny struct pwd field"); + $feep; + }; + + exists $Config{ "d_" . $feep } + || confess("$IE Configure doesn't d_$feep"); + $Groks{$short} = defined $Config{ "d_" . $feep }; + } + # assume that any that are left are always there + for my $feep (grep /^\$pw_/s, @EXPORT_OK) { + $feep =~ /^\$pw_(.*)/; + $Groks{$1} = 1 unless defined $Groks{$1}; + } +} + +# With arguments, reports whether one or more fields are all implemented +# in the build machine's struct pwd pw_*. May be whitespace separated. +# We do not use /^pw_?/, just the tails. +# +# Without arguments, returns the list of fields implemented on build +# machine, space separated in scalar context. +# +# Takes exception to being asked whether this machine's struct pwd has +# a field that Perl never knows how to provide under any circumstances. +# If the module does this idiocy to itself, the explosion is noisier. +# +sub pw_has { + our %Groks; # whether build system knew how to do this feature + my $cando = 1; + my $sploder = caller() ne __PACKAGE__ + ? \&croak + : sub { confess("$IE @_") }; + if (@_ == 0) { + my @valid = sort grep { $Groks{$_} } keys %Groks; + return wantarray ? @valid : "@valid"; + } + for my $feep (map { split } @_) { + defined $Groks{$feep} + || $sploder->("$feep is never a valid struct pwd field"); + $cando &&= $Groks{$feep}; + } + return $cando; +} + +sub _populate (@) { return unless @_; my $pwob = new(); - ( $pw_name, $pw_passwd, $pw_uid, - $pw_gid, $pw_quota, $pw_comment, - $pw_gecos, $pw_dir, $pw_shell, ) = @$pwob = @_; + # Any that haven't been pw_had are assumed on "all" platforms of + # course, this may not be so, but you can't get here otherwise, + # since the underlying core call already took exception to your + # impudence. + + $pw_name = $pwob->name ( $_[0] ); + $pw_passwd = $pwob->passwd ( $_[1] ) if pw_has("passwd"); + $pw_uid = $pwob->uid ( $_[2] ); + $pw_gid = $pwob->gid ( $_[3] ); + + if (pw_has("change")) { + $pw_change = $pwob->change ( $_[4] ); + } + elsif (pw_has("age")) { + $pw_age = $pwob->age ( $_[4] ); + } + elsif (pw_has("quota")) { + $pw_quota = $pwob->quota ( $_[4] ); + } + + if (pw_has("class")) { + $pw_class = $pwob->class ( $_[5] ); + } + elsif (pw_has("comment")) { + $pw_comment = $pwob->comment( $_[5] ); + } + + $pw_gecos = $pwob->gecos ( $_[6] ) if pw_has("gecos"); + + $pw_dir = $pwob->dir ( $_[7] ); + $pw_shell = $pwob->shell ( $_[8] ); + + $pw_expire = $pwob->expire ( $_[9] ) if pw_has("expire"); return $pwob; -} +} -sub getpwent ( ) { populate(CORE::getpwent()) } -sub getpwnam ($) { populate(CORE::getpwnam(shift)) } -sub getpwuid ($) { populate(CORE::getpwuid(shift)) } -sub getpw ($) { ($_[0] =~ /^\d+/) ? &getpwuid : &getpwnam } +sub getpwent ( ) { _populate(CORE::getpwent()) } +sub getpwnam ($) { _populate(CORE::getpwnam(shift)) } +sub getpwuid ($) { _populate(CORE::getpwuid(shift)) } +sub getpw ($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam } + +_feature_init(); 1; __END__ @@ -57,42 +185,95 @@ User::pwent - by-name interface to Perl's built-in getpw*() functions =head1 SYNOPSIS use User::pwent; - $pw = getpwnam('daemon') or die "No daemon user"; - if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?$# ) { + $pw = getpwnam('daemon') || die "No daemon user"; + if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?\z#s ) { print "gid 1 on root dir"; - } + } + + $real_shell = $pw->shell || '/bin/sh'; + + for (($fullname, $office, $workphone, $homephone) = + split /\s*,\s*/, $pw->gecos) + { + s/&/ucfirst(lc($pw->name))/ge; + } use User::pwent qw(:FIELDS); - getpwnam('daemon') or die "No daemon user"; - if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?$# ) { + getpwnam('daemon') || die "No daemon user"; + if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?\z#s ) { print "gid 1 on root dir"; - } + } $pw = getpw($whoever); + use User::pwent qw/:DEFAULT pw_has/; + if (pw_has(qw[gecos expire quota])) { .... } + if (pw_has("name uid gid passwd")) { .... } + print "Your struct pwd has: ", scalar pw_has(), "\n"; + =head1 DESCRIPTION This module's default exports override the core getpwent(), getpwuid(), and getpwnam() functions, replacing them with versions that return -"User::pwent" objects. This object has methods that return the similarly -named structure field name from the C's passwd structure from F<pwd.h>; -namely name, passwd, uid, gid, quota, comment, gecos, dir, and shell. +C<User::pwent> objects. This object has methods that return the +similarly named structure field name from the C's passwd structure +from F<pwd.h>, stripped of their leading "pw_" parts, namely C<name>, +C<passwd>, C<uid>, C<gid>, C<change>, C<age>, C<quota>, C<comment>, +C<class>, C<gecos>, C<dir>, C<shell>, and C<expire>. The C<passwd>, +C<gecos>, and C<shell> fields are tainted when running in taint mode. -You may also import all the structure fields directly into your namespace -as regular variables using the :FIELDS import tag. (Note that this still -overrides your core functions.) Access these fields as -variables named with a preceding C<pw_> in front their method names. -Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import -the fields. +You may also import all the structure fields directly into your +namespace as regular variables using the :FIELDS import tag. (Note +that this still overrides your core functions.) Access these fields +as variables named with a preceding C<pw_> in front their method +names. Thus, C<< $passwd_obj->shell >> corresponds to $pw_shell +if you import the fields. The getpw() function is a simple front-end that forwards a numeric argument to getpwuid() and the rest to getpwnam(). -To access this functionality without the core overrides, -pass the C<use> an empty import list, and then access -function functions with their full qualified names. -On the other hand, the built-ins are still available -via the C<CORE::> pseudo-package. +To access this functionality without the core overrides, pass the +C<use> an empty import list, and then access function functions +with their full qualified names. The built-ins are always still +available via the C<CORE::> pseudo-package. + +=head2 System Specifics + +Perl believes that no machine ever has more than one of C<change>, +C<age>, or C<quota> implemented, nor more than one of either +C<comment> or C<class>. Some machines do not support C<expire>, +C<gecos>, or allegedly, C<passwd>. You may call these methods +no matter what machine you're on, but they return C<undef> if +unimplemented. + +You may ask whether one of these was implemented on the system Perl +was built on by asking the importable C<pw_has> function about them. +This function returns true if all parameters are supported fields +on the build platform, false if one or more were not, and raises +an exception if you asked about a field that Perl never knows how +to provide. Parameters may be in a space-separated string, or as +separate arguments. If you pass no parameters, the function returns +the list of C<struct pwd> fields supported by your build platform's +C library, as a list in list context, or a space-separated string +in scalar context. Note that just because your C library had +a field doesn't necessarily mean that it's fully implemented on +that system. + +Interpretation of the C<gecos> field varies between systems, but +traditionally holds 4 comma-separated fields containing the user's +full name, office location, work phone number, and home phone number. +An C<&> in the gecos field should be replaced by the user's properly +capitalized login C<name>. The C<shell> field, if blank, must be +assumed to be F</bin/sh>. Perl does not do this for you. The +C<passwd> is one-way hashed garble, not clear text, and may not be +unhashed save by brute-force guessing. Secure systems use more a +more secure hashing than DES. On systems supporting shadow password +systems, Perl automatically returns the shadow password entry when +called by a suitably empowered user, even if your underlying +vendor-provided C library was too short-sighted to realize it should +do this. + +See passwd(5) and getpwent(3) for details. =head1 NOTE @@ -102,3 +283,15 @@ module to build a struct-like class, you shouldn't rely upon this. =head1 AUTHOR Tom Christiansen + +=head1 HISTORY + +=over + +=item March 18th, 2000 + +Reworked internals to support better interface to dodgey fields +than normal Perl function provides. Added pw_has() field. Improved +documentation. + +=back diff --git a/lib/charnames.pm b/lib/charnames.pm index 21b4dd61bc..7c2209b9f0 100644 --- a/lib/charnames.pm +++ b/lib/charnames.pm @@ -2,7 +2,6 @@ package charnames; use bytes (); # for $bytes::hint_bits $charnames::hint_bits = 0x20000; -my $fname = 'unicode/UnicodeData-Latest.txt'; my $txt; # This is not optimized in any way yet diff --git a/lib/constant.pm b/lib/constant.pm index b4fcd421ac..72ad793653 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -2,9 +2,10 @@ package constant; use strict; use 5.005_64; +use warnings::register; our($VERSION, %declared); -$VERSION = '1.01'; +$VERSION = '1.02'; #======================================================================= @@ -51,18 +52,17 @@ sub import { # Maybe the name is tolerable } elsif ($name =~ /^[A-Za-z_]\w*\z/) { # Then we'll warn only if you've asked for warnings - if ($^W) { - require Carp; + if (warnings::enabled()) { if ($keywords{$name}) { - Carp::carp("Constant name '$name' is a Perl keyword"); + warnings::warn("Constant name '$name' is a Perl keyword"); } elsif ($forced_into_main{$name}) { - Carp::carp("Constant name '$name' is " . + warnings::warn("Constant name '$name' is " . "forced into package main::"); } else { # Catch-all - what did I miss? If you get this error, # please let me know what your constant's name was. # Write to <rootbeer@redcat.com>. Thanks! - Carp::carp("Constant name '$name' has unknown problems"); + warnings::warn("Constant name '$name' has unknown problems"); } } diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index a2c927baca..884ea3ca65 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -44,7 +44,7 @@ These still go out B<STDERR>. Due to the interaction between runtime and compiletime issues, and because it's probably not a very good idea anyway, you may not use C<no diagnostics> to turn them off at compiletime. -However, you may control there behaviour at runtime using the +However, you may control their behaviour at runtime using the disable() and enable() methods to turn them off and on respectively. The B<-verbose> flag first prints out the L<perldiag> introduction before @@ -167,19 +167,23 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. =cut +use strict; use 5.005_64; use Carp; -$VERSION = v1.0; +our $VERSION = v1.0; +our $DEBUG; +our $VERBOSE; +our $PRETTY; use Config; -($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; +my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; if ($^O eq 'VMS') { require VMS::Filespec; $privlib = VMS::Filespec::unixify($privlib); $archlib = VMS::Filespec::unixify($archlib); } -@trypod = ( +my @trypod = ( "$archlib/pod/perldiag.pod", "$privlib/pod/perldiag-$Config{version}.pod", "$privlib/pod/perldiag.pod", @@ -189,21 +193,21 @@ if ($^O eq 'VMS') { ); # handy for development testing of new warnings etc unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; -($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; +(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; $DEBUG ||= 0; my $WHOAMI = ref bless []; # nobody's business, prolly not even mine -$| = 1; - +local $| = 1; local $_; +my $standalone; +my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7); + CONFIG: { - $opt_p = $opt_d = $opt_v = $opt_f = ''; - %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = (); - %exact_duplicate = (); + our $opt_p = our $opt_d = our $opt_v = our $opt_f = ''; - unless (caller) { + unless (caller) { $standalone++; require Getopt::Std; Getopt::Std::getopts('pdvf:') @@ -212,7 +216,7 @@ CONFIG: { $DEBUG = 2 if $opt_d; $VERBOSE = $opt_v; $PRETTY = $opt_p; - } + } if (open(POD_DIAG, $PODFILE)) { warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; @@ -221,11 +225,12 @@ CONFIG: { if (caller) { INCPATH: { - for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { + for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { warn "Checking $file\n" if $DEBUG; if (open(POD_DIAG, $file)) { while (<POD_DIAG>) { - next unless /^__END__\s*# wish diag dbase were more accessible/; + next unless + /^__END__\s*# wish diag dbase were more accessible/; print STDERR "podfile is $file\n" if $DEBUG; last INCPATH; } @@ -274,6 +279,7 @@ if (eof(POD_DIAG)) { # etc ); +our %HTML_Escapes; *HTML_Escapes = do { if ($standalone) { $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; @@ -284,20 +290,20 @@ if (eof(POD_DIAG)) { *THITHER = $standalone ? *STDOUT : *STDERR; -$transmo = <<EOFUNC; +my $transmo = <<EOFUNC; sub transmo { #local \$^W = 0; # recursive warnings we do NOT need! study; EOFUNC -### sub finish_compilation { # 5.001e panic: top_level for embedded version +my %msg; +{ print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; - ### local - $RS = ''; + local $/ = ''; local $_; + my $header; + my $for_item; while (<POD_DIAG>) { - #s/(.*)\n//; - #$header = $1; unescape(); if ($PRETTY) { @@ -321,29 +327,35 @@ EOFUNC } s/^/ /gm; $msg{$header} .= $_; + undef $for_item; } next; } - unless ( s/=item (.*)\s*\Z//) { + unless ( s/=item (.*?)\s*\z//) { if ( s/=head1\sDESCRIPTION//) { $msg{$header = 'DESCRIPTION'} = ''; + undef $for_item; } + elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) { + $for_item = $1; + } next; } # strip formatting directives in =item line - ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; + $header = $for_item || $1; + undef $for_item; + $header =~ s/[A-Z]<(.*?)>/$1/g; if ($header =~ /%[csd]/) { - $rhs = $lhs = $header; - #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { - if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { + my $rhs = my $lhs = $header; + if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g) { $lhs =~ s/\\%s/.*?/g; } else { - # if i had lookbehind negations, i wouldn't have to do this \377 noise + # if i had lookbehind negations, + # i wouldn't have to do this \377 noise $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; - #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; $lhs =~ s/\377([^\377]*)$/\Q$1\E/; $lhs =~ s/\377//g; $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all @@ -369,25 +381,23 @@ EOFUNC print STDERR $transmo if $DEBUG; eval $transmo; die $@ if $@; - $RS = "\n"; -### } +} if ($standalone) { if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } - while (defined ($error = <>)) { + while (defined (my $error = <>)) { splainthis($error) || print THITHER $error; } exit; -} else { - #$old_w = 0; - $oldwarn = ''; $olddie = ''; -} +} + +my $olddie; +my $oldwarn; sub import { shift; - #$old_w = $^W; - $^W = 1; # yup, clobbered the global variable; tough, if you - # want diags, you want diags. + $^W = 1; # yup, clobbered the global variable; + # tough, if you want diags, you want diags. return if $SIG{__WARN__} eq \&warn_trap; for (@_) { @@ -421,10 +431,9 @@ sub enable { &import } sub disable { shift; - #$^W = $old_w; return unless $SIG{__WARN__} eq \&warn_trap; - $SIG{__WARN__} = $oldwarn; - $SIG{__DIE__} = $olddie; + $SIG{__WARN__} = $oldwarn || ''; + $SIG{__DIE__} = $olddie || ''; } sub warn_trap { @@ -465,6 +474,10 @@ sub death_trap { # into an indirect recursion loop }; +my %exact_duplicate; +my %old_diag; +my $count; +my $wantspace; sub splainthis { local $_ = shift; local $\; @@ -473,7 +486,7 @@ sub splainthis { my $orig = $_; # return unless defined; s/, <.*?> (?:line|chunk).*$//; - $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; + my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; s/^\((.*)\)$/$1/; if ($exact_duplicate{$orig}++) { return &transmo; @@ -542,8 +555,5 @@ sub shorten { } -# have to do this: RS isn't set until run time, but we're executing at compiletime -$RS = "\n"; - 1 unless $standalone; # or it'll complain about itself __END__ # wish diag dbase were more accessible diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index c72781801b..51e9c88ea3 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -195,8 +195,8 @@ sub unwrap { if ($#$v >= 0) { $short = $sp . "0..$#{$v} " . join(" ", - map {stringify $_} @{$v}[0..$tArrayDepth]) - . "$shortmore"; + map {exists $v->[$_] ? stringify $v->[$_] : "empty"} ($[..$tArrayDepth) + ) . "$shortmore"; } else { $short = $sp . "empty array"; } @@ -209,7 +209,11 @@ sub unwrap { for $num ($[ .. $tArrayDepth) { return if $DB::signal; print "$sp$num "; - DumpElem $v->[$num], $s; + if (exists $v->[$num]) { + DumpElem $v->[$num], $s; + } else { + print "empty slot\n"; + } } print "$sp empty array\n" unless @$v; print "$sp$more" if defined $more ; @@ -361,7 +365,9 @@ sub main::dumpvar { return if $DB::signal; next if @vars && !grep( matchvar($key, $_), @vars ); if ($usageOnly) { - globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab'; + globUsage(\$val, $key) + if ($package ne 'dumpvar' or $key ne 'stab') + and ref(\$val) eq 'GLOB'; } else { dumpglob(0,$key, $val); } diff --git a/lib/fields.pm b/lib/fields.pm index 5a84e28f2e..ac4581036f 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -130,6 +130,7 @@ L<perlref/Pseudo-hashes: Using an array as a hash> use 5.005_64; use strict; no strict 'refs'; +use warnings::register; our(%attr, $VERSION); $VERSION = "1.01"; @@ -171,7 +172,8 @@ sub import { if ($fno and $fno != $next) { require Carp; if ($fno < $fattr->[0]) { - Carp::carp("Hides field '$f' in base class") if $^W; + warnings::warn("Hides field '$f' in base class") + if warnings::enabled(); } else { Carp::croak("Field name '$f' already in use"); } diff --git a/lib/open.pm b/lib/open.pm index a845459da6..cdd20ac2c3 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -56,12 +56,12 @@ When they are eventually supported, this pragma will serve as one of the interfaces to declare default disciplines for all I/O. In future, any default disciplines declared by this pragma will be -available by the special discipline name ":def", and could be used +available by the special discipline name ":DEFAULT", and could be used within handle constructors that allow disciplines to be specified. This would make it possible to stack new disciplines over the default ones. - open FH, "<:para :def", $file or die "can't open $file: $!"; + open FH, "<:para :DEFAULT", $file or die "can't open $file: $!"; Socket and directory handles will also support disciplines in future. diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 7c5b0a909c..41430ac188 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,17 +2,9 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.06; +$VERSION = 1.07; $header = "perl5db.pl version $VERSION"; -# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) -# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl - -# modified Perl debugger, to be run from Emacs in perldb-mode -# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 -# Johan Vromans -- upgrade to 4.0 pl 10 -# Ilya Zakharevich -- patches after 5.001 (and some before ;-) - # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. @@ -42,7 +34,7 @@ $header = "perl5db.pl version $VERSION"; # interpreter, though the values used by perl5db.pl have the form # "$break_condition\0$action". Values are magical in numeric context. # -# The scalar ${'_<'.$filename} contains "_<$filename". +# The scalar ${'_<'.$filename} contains $filename. # # Note that no subroutine call is possible until &DB::sub is defined # (for subroutines defined outside of the package DB). In fact the same is @@ -88,6 +80,15 @@ $header = "perl5db.pl version $VERSION"; # reset LineInfo to something "interactive"!) # ################################################################## + +# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) +# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl + +# modified Perl debugger, to be run from Emacs in perldb-mode +# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 +# Johan Vromans -- upgrade to 4.0 pl 10 +# Ilya Zakharevich -- patches after 5.001 (and some before ;-) + # Changelog: # A lot of things changed after 0.94. First of all, core now informs @@ -144,6 +145,48 @@ $header = "perl5db.pl version $VERSION"; # `b load' strips trailing whitespace. # completion ignores leading `|'; takes into account current package # when completing a subroutine name (same for `l'). +# Changes: 1.07: Many fixed by tchrist 13-March-2000 +# BUG FIXES: +# + Added bare mimimal security checks on perldb rc files, plus +# comments on what else is needed. +# + Fixed the ornaments that made "|h" completely unusable. +# They are not used in print_help if they will hurt. Strip pod +# if we're paging to less. +# + Fixed mis-formatting of help messages caused by ornaments +# to restore Larry's original formatting. +# + Fixed many other formatting errors. The code is still suboptimal, +# and needs a lot of work at restructuing. It's also misindented +# in many places. +# + Fixed bug where trying to look at an option like your pager +# shows "1". +# + Fixed some $? processing. Note: if you use csh or tcsh, you will +# lose. You should consider shell escapes not using their shell, +# or else not caring about detailed status. This should really be +# unified into one place, too. +# + Fixed bug where invisible trailing whitespace on commands hoses you, +# tricking Perl into thinking you wern't calling a debugger command! +# + Fixed bug where leading whitespace on commands hoses you. (One +# suggests a leading semicolon or any other irrelevant non-whitespace +# to indicate literal Perl code.) +# + Fixed bugs that ate warnings due to wrong selected handle. +# + Fixed a precedence bug on signal stuff. +# + Fixed some unseemly wording. +# + Fixed bug in help command trying to call perl method code. +# + Fixed to call dumpvar from exception handler. SIGPIPE killed us. +# ENHANCEMENTS: +# + Added some comments. This code is still nasty spaghetti. +# + Added message if you clear your pre/post command stacks which was +# very easy to do if you just typed a bare >, <, or {. (A command +# without an argument should *never* be a destructive action; this +# API is fundamentally screwed up; likewise option setting, which +# is equally buggered.) +# + Added command stack dump on argument of "?" for >, <, or {. +# + Added a semi-built-in doc viewer command that calls man with the +# proper %Config::Config path (and thus gets caching, man -k, etc), +# or else perldoc on obstreperous platforms. +# + Added to and rearranged the help information. +# + Detected apparent misuse of { ... } to declare a block; this used +# to work but now is a command, and mysteriously gave no complaint. #################################################################### @@ -230,43 +273,93 @@ $inhibit_exit = $option{PrintRet} = 1; ); # These guys may be defined in $ENV{PERL5DB} : -$rl = 1 unless defined $rl; -$warnLevel = 1 unless defined $warnLevel; -$dieLevel = 1 unless defined $dieLevel; -$signalLevel = 1 unless defined $signalLevel; -$pre = [] unless defined $pre; -$post = [] unless defined $post; -$pretype = [] unless defined $pretype; +$rl = 1 unless defined $rl; +$warnLevel = 0 unless defined $warnLevel; +$dieLevel = 0 unless defined $dieLevel; +$signalLevel = 1 unless defined $signalLevel; +$pre = [] unless defined $pre; +$post = [] unless defined $post; +$pretype = [] unless defined $pretype; + warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -&pager((defined($ENV{PAGER}) + +&pager( + (defined($ENV{PAGER}) ? $ENV{PAGER} : ($^O eq 'os2' ? 'cmd /c more' : 'more'))) unless defined $pager; +setman(); &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; $maxtrace = 400 unless defined $maxtrace; -if (-e "/dev/tty") { +if (-e "/dev/tty") { # this is the wrong metric! $rcfile=".perldb"; } else { $rcfile="perldb.ini"; } +# This isn't really safe, because there's a race +# between checking and opening. The solution is to +# open and fstat the handle, but then you have to read and +# eval the contents. But then the silly thing gets +# your lexical scope, which is unfortunately at best. +sub safe_do { + my $file = shift; + + # Just exactly what part of the word "CORE::" don't you understand? + local $SIG{__WARN__}; + local $SIG{__DIE__}; + + unless (is_safe_file($file)) { + CORE::warn <<EO_GRIPE; +perldb: Must not source insecure rcfile $file. + You or the superuser must be the owner, and it must not + be writable by anyone but its owner. +EO_GRIPE + return; + } + + do $file; + CORE::warn("perldb: couldn't parse $file: $@") if $@; +} + + +# Verifies that owner is either real user or superuser and that no +# one but owner may write to it. This function is of limited use +# when called on a path instead of upon a handle, because there are +# no guarantees that filename (by dirent) whose file (by ino) is +# eventually accessed is the same as the one tested. +# Assumes that the file's existence is not in doubt. +sub is_safe_file { + my $path = shift; + stat($path) || return; # mysteriously vaporized + my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_); + + return 0 if $uid != 0 && $uid != $<; + return 0 if $mode & 022; + return 1; +} + if (-f $rcfile) { - do "./$rcfile"; -} elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") { - do "$ENV{LOGDIR}/$rcfile"; -} elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") { - do "$ENV{HOME}/$rcfile"; + safe_do("./$rcfile"); +} +elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") { + safe_do("$ENV{HOME}/$rcfile"); +} +elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") { + safe_do("$ENV{LOGDIR}/$rcfile"); } if (defined $ENV{PERLDB_OPTS}) { parse_options($ENV{PERLDB_OPTS}); } +# Here begin the unreadable code. It needs fixing. + if (exists $ENV{PERLDB_RESTART}) { delete $ENV{PERLDB_RESTART}; # $restart = 1; @@ -295,9 +388,9 @@ if (exists $ENV{PERLDB_RESTART}) { if ($notty) { $runnonstop = 1; } else { - # Is Perl being run from Emacs? - $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs')); - $rl = 0, shift(@main::ARGV) if $emacs; + # Is Perl being run from a slave editor or graphical debugger? + $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs')); + $rl = 0, shift(@main::ARGV) if $slave_editor; #require Term::ReadLine; @@ -312,12 +405,12 @@ if ($notty) { $console = "sys\$command"; } - if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) { + if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) { $console = undef; } # Around a bug: - if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2 + if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2 $console = undef; } @@ -363,10 +456,10 @@ if ($notty) { $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; unless ($runnonstop) { print $OUT "\nLoading DB routines from $header\n"; - print $OUT ("Emacs support ", - $emacs ? "enabled" : "available", + print $OUT ("Editor support ", + $slave_editor ? "enabled" : "available", ".\n"); - print $OUT "\nEnter h or `h h' for help, run `perldoc perldebug' for more help.\n\n"; + print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n"; } } @@ -439,7 +532,7 @@ EOP $was_signal = $signal; $signal = 0; if ($single || ($trace & 1) || $was_signal) { - if ($emacs) { + if ($slave_editor) { $position = "\032\032$filename:$line:0\n"; print $LINEINFO $position; } elsif ($package eq 'DB::fake') { @@ -500,7 +593,8 @@ EOP ($term_pid == $$ or &resetterm), defined ($cmd=&readline(" DB" . ('<' x $level) . ($#hist+1) . ('>' x $level) . - " "))) { + " "))) + { $single = 0; $signal = 0; $cmd =~ s/\\$/\n/ && do { @@ -510,8 +604,19 @@ EOP $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; PIPE: { + $cmd =~ s/^\s+//s; # trim annoying leading whitespace + $cmd =~ s/\s+$//s; # trim annoying trailing whitespace ($i) = split(/\s+/,$cmd); - eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i}; + if ($alias{$i}) { + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; + eval "\$cmd =~ $alias{$i}"; + if ($@) { + print $OUT "Couldn't evaluate `$i' alias: $@"; + next CMD; + } + } $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^h$/ && do { print_help($help); @@ -519,10 +624,14 @@ EOP $cmd =~ /^h\s+h$/ && do { print_help($summary); next CMD; }; - $cmd =~ /^h\s+(\S)$/ && do { - my $asked = "\Q$1"; - if ($help =~ /^(?:[IB]<)$asked/m) { - while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) { + # support long commands; otherwise bogus errors + # happen when you ask for h on <CR> for example + $cmd =~ /^h\s+(\S.*)$/ && do { + my $asked = $1; # for proper errmsg + my $qasked = quotemeta($asked); # for searching + # XXX: finds CR but not <CR> + if ($help =~ /^<?(?:[IB]<)$qasked/m) { + while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) { print_help($1); } } else { @@ -555,7 +664,11 @@ EOP if (defined &main::dumpvar) { local $frame = 0; local $doret = -2; - &main::dumpvar($packname,@vars); + # must detect sigpipe failures + eval { &main::dumpvar($packname,@vars) }; + if ($@) { + die unless $@ =~ /dumpvar print failed/; + } } else { print $OUT "dumpvar.pl not available.\n"; } @@ -616,7 +729,7 @@ EOP $file = join(':', @pieces); if ($file ne $filename) { print $OUT "Switching to file '$file'.\n" - unless $emacs; + unless $slave_editor; *dbline = $main::{'_<' . $file}; $max = $#dbline; $filename = $file; @@ -664,7 +777,7 @@ EOP $i = $line if $i eq '.'; $i = 1 if $i < 1; $incr = $end - $i; - if ($emacs) { + if ($slave_editor) { print $OUT "\032\032$filename:$i:0\n"; $i = $end; } else { @@ -846,7 +959,7 @@ EOP } } - if (not $had_breakpoints{$file} &= ~2) { + unless ($had_breakpoints{$file} &= ~2) { delete $had_breakpoints{$file}; } } @@ -866,18 +979,75 @@ EOP push @$post, action($1); next CMD; }; $cmd =~ /^<\s*(.*)/ && do { - $pre = [], next CMD unless $1; + unless ($1) { + print OUT "All < actions cleared.\n"; + $pre = []; + next CMD; + } + if ($1 eq '?') { + unless (@$pre) { + print OUT "No pre-prompt Perl actions.\n"; + next CMD; + } + print OUT "Perl commands run before each prompt:\n"; + for my $action ( @$pre ) { + print "\t< -- $action\n"; + } + next CMD; + } $pre = [action($1)]; next CMD; }; $cmd =~ /^>\s*(.*)/ && do { - $post = [], next CMD unless $1; + unless ($1) { + print OUT "All > actions cleared.\n"; + $post = []; + next CMD; + } + if ($1 eq '?') { + unless (@$post) { + print OUT "No post-prompt Perl actions.\n"; + next CMD; + } + print OUT "Perl commands run after each prompt:\n"; + for my $action ( @$post ) { + print "\t> -- $action\n"; + } + next CMD; + } $post = [action($1)]; next CMD; }; $cmd =~ /^\{\{\s*(.*)/ && do { + if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { + print OUT "{{ is now a debugger command\n", + "use `;{{' if you mean Perl code\n"; + $cmd = "h {{"; + redo CMD; + } push @$pretype, $1; next CMD; }; $cmd =~ /^\{\s*(.*)/ && do { - $pretype = [], next CMD unless $1; + unless ($1) { + print OUT "All { actions cleared.\n"; + $pretype = []; + next CMD; + } + if ($1 eq '?') { + unless (@$pretype) { + print OUT "No pre-prompt debugger actions.\n"; + next CMD; + } + print OUT "Debugger commands run before each prompt:\n"; + for my $action ( @$pretype ) { + print "\t{ -- $action\n"; + } + next CMD; + } + if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { + print OUT "{ is now a debugger command\n", + "use `;{' if you mean Perl code\n"; + $cmd = "h {"; + redo CMD; + } $pretype = [$1]; next CMD; }; $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do { @@ -957,7 +1127,7 @@ EOP set_list("PERLDB_INC", @ini_INC); if ($0 eq '-e') { for (1..$#{'::_<-e'}) { # The first line is PERL5DB - chomp ($cl = $ {'::_<-e'}[$_]); + chomp ($cl = ${'::_<-e'}[$_]); push @script, '-e', $cl; } } else { @@ -1021,8 +1191,8 @@ EOP set_list("PERLDB_POST", @$post); set_list("PERLDB_TYPEAHEAD", @typeahead); $ENV{PERLDB_RESTART} = 1; - #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS"; - exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS; + #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS"; + exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS; print $OUT "exec failed: $!\n"; last CMD; }; $cmd =~ /^T$/ && do { @@ -1044,6 +1214,9 @@ EOP $inpat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print $OUT "$@"; @@ -1059,7 +1232,7 @@ EOP $start = 1 if ($start > $max); last if ($start == $end); if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { - if ($emacs) { + if ($slave_editor) { print $OUT "\032\032$filename:$start:0\n"; } else { print $OUT "$start:\t", $dbline[$start], "\n"; @@ -1073,9 +1246,12 @@ EOP $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; if ($inpat ne "") { + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { - print $OUT "$@"; + print $OUT $@; next CMD; } $pat = $inpat; @@ -1088,7 +1264,7 @@ EOP $start = $max if ($start <= 0); last if ($start == $end); if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { - if ($emacs) { + if ($slave_editor) { print $OUT "\032\032$filename:$start:0\n"; } else { print $OUT "$start:\t", $dbline[$start], "\n"; @@ -1124,31 +1300,56 @@ EOP &system($ENV{SHELL}||"/bin/sh"); next CMD; }; $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do { + # XXX: using csh or tcsh destroys sigint retvals! + #&system($1); # use this instead &system($ENV{SHELL}||"/bin/sh","-c",$1); next CMD; }; $cmd =~ /^H\b\s*(-(\d+))?/ && do { - $end = $2?($#hist-$2):0; + $end = $2 ? ($#hist-$2) : 0; $hist = 0 if $hist < 0; for ($i=$#hist; $i>$end; $i--) { print $OUT "$i: ",$hist[$i],"\n" unless $hist[$i] =~ /^.?$/; }; next CMD; }; + $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do { + runman($1); + next CMD; }; $cmd =~ s/^p$/print {\$DB::OUT} \$_/; $cmd =~ s/^p\b/print {\$DB::OUT} /; - $cmd =~ /^=/ && do { - if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { - $alias{$k}="s~$k~$v~"; - print $OUT "$k = $v\n"; - } elsif ($cmd =~ /^=\s*$/) { - foreach $k (sort keys(%alias)) { - if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { - print $OUT "$k = $v\n"; - } else { + $cmd =~ s/^=\s*// && do { + my @keys; + if (length $cmd == 0) { + @keys = sort keys %alias; + } + elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) { + # can't use $_ or kill //g state + for my $x ($k, $v) { $x =~ s/\a/\\a/g } + $alias{$k} = "s\a$k\a$v\a"; + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; + unless (eval "sub { s\a$k\a$v\a }; 1") { + print $OUT "Can't alias $k to $v: $@\n"; + delete $alias{$k}; + next CMD; + } + @keys = ($k); + } + else { + @keys = ($cmd); + } + for my $k (@keys) { + if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) { + print $OUT "$k\t= $1\n"; + } + elsif (defined $alias{$k}) { print $OUT "$k\t$alias{$k}\n"; - }; - }; - }; + } + else { + print "No alias for $k\n"; + } + } next CMD; }; $cmd =~ /^\|\|?\s*[^|]/ && do { if ($pager =~ /^\|/) { @@ -1157,25 +1358,29 @@ EOP } else { open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT"); } + fix_less(); unless ($piped=open(OUT,$pager)) { &warn("Can't pipe output to `$pager'"); if ($pager =~ /^\|/) { - open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT"); + open(OUT,">&STDOUT") # XXX: lost message + || &warn("Can't restore DB::OUT"); open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); close(SAVEOUT); } else { - open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT"); + open(OUT,">&STDOUT") # XXX: lost message + || &warn("Can't restore DB::OUT"); } next CMD; } $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/ - && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE}; + && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE}); $selected= select(OUT); $|= 1; select( $selected ), $selected= "" unless $cmd =~ /^\|\|/; $cmd =~ s/^\|+\s*//; - redo PIPE; }; + redo PIPE; + }; # XXX Local variants do not work! $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; @@ -1190,14 +1395,27 @@ EOP } continue { # CMD: if ($piped) { if ($pager =~ /^\|/) { - $?= 0; close(OUT) || &warn("Can't close DB::OUT"); - &warn( "Pager `$pager' failed: ", - ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), - ( $? & 128 ) ? " (core dumped)" : "", - ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?; + $? = 0; + # we cannot warn here: the handle is missing --tchrist + close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; + + # most of the $? crud was coping with broken cshisms + if ($?) { + print SAVEOUT "Pager `$pager' failed: "; + if ($? == -1) { + print SAVEOUT "shell returned -1\n"; + } elsif ($? >> 8) { + print SAVEOUT + ( $? & 127 ) ? " (SIG#".($?&127).")" : "", + ( $? & 128 ) ? " -- core dumped" : "", "\n"; + } else { + print SAVEOUT "status ", ($? >> 8), "\n"; + } + } + open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT"); open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); - $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch; + $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; # Will stop ignoring SIGPIPE if done like nohup(1) # does SIGINT but Perl doesn't give us a choice. } else { @@ -1282,7 +1500,9 @@ sub save { # The following takes its argument via $evalarg to preserve current @_ sub eval { - local @res; # 'my' would make it visible from user code + # 'my' would make it visible from user code + # but so does local! --tchrist + local @res; { local $otrace = $trace; local $osingle = $single; @@ -1347,7 +1567,7 @@ sub postponed { #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic my $key; for $key (keys %{$postponed_file{$filename}}) { - $dbline{$key} = $ {$postponed_file{$filename}}{$key}; + $dbline{$key} = ${$postponed_file{$filename}}{$key}; } delete $postponed_file{$filename}; } @@ -1463,27 +1683,50 @@ sub action { $action; } +sub unbalanced { + # i hate using globals! + $balanced_brace_re ||= qr{ + ^ \{ + (?: + (?> [^{}] + ) # Non-parens without backtracking + | + (??{ $balanced_brace_re }) # Group with matching parens + ) * + \} $ + }x; + return $_[0] !~ m/$balanced_brace_re/; +} + sub gets { - local($.); - #<IN>; &readline("cont: "); } sub system { # We save, change, then restore STDIN and STDOUT to avoid fork() since - # many non-Unix systems can do system() but have problems with fork(). + # some non-Unix systems can do system() but have problems with fork(). open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN"); open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT"); open(STDIN,"<&IN") || &warn("Can't redirect STDIN"); open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT"); + + # XXX: using csh or tcsh destroys sigint retvals! system(@_); open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN"); open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); - close(SAVEIN); close(SAVEOUT); - &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")", - ( $? & 128 ) ? " (core dumped)" : "", - ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?; - $?; + close(SAVEIN); + close(SAVEOUT); + + + # most of the $? crud was coping with broken cshisms + if ($? >> 8) { + &warn("(Command exited ", ($? >> 8), ")\n"); + } elsif ($?) { + &warn( "(Command died of SIG#", ($? & 127), + (($? & 128) ? " -- core dumped" : "") , ")", "\n"); + } + + return $?; + } sub setterm { @@ -1500,7 +1743,7 @@ sub setterm { $| = 1; select($sel); } else { - eval "require Term::Rendezvous;" or die $@; + eval "require Term::Rendezvous;" or die; my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$"; my $term_rv = new Term::Rendezvous $rv; $IN = $term_rv->IN; @@ -1559,6 +1802,7 @@ EOP } sub readline { + local $.; if (@typeahead) { my $left = @typeahead; my $got = shift @typeahead; @@ -1572,7 +1816,7 @@ sub readline { if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { print $OUT @_; my $stuff; - $IN->recv( $stuff, 2048 ); + $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread? $stuff; } else { @@ -1591,15 +1835,15 @@ sub option_val { my ($opt, $default)= @_; my $val; if (defined $optionVars{$opt} - and defined $ {$optionVars{$opt}}) { - $val = $ {$optionVars{$opt}}; + and defined ${$optionVars{$opt}}) { + $val = ${$optionVars{$opt}}; } elsif (defined $optionAction{$opt} and defined &{$optionAction{$opt}}) { $val = &{$optionAction{$opt}}(); } elsif (defined $optionAction{$opt} and not defined $option{$opt} or defined $optionVars{$opt} - and not defined $ {$optionVars{$opt}}) { + and not defined ${$optionVars{$opt}}) { $val = $default; } else { $val = $option{$opt}; @@ -1609,8 +1853,16 @@ sub option_val { sub parse_options { local($_)= @_; - while ($_ ne "") { - s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last; + # too dangerous to let intuitive usage overwrite important things + # defaultion should never be the default + my %opt_needs_val = map { ( $_ => 1 ) } qw{ + arrayDepth hashDepth LineInfo maxTraceLen ornaments + pager quote ReadLine recallCommand RemotePort ShellBang TTY + }; + while (length) { + my $val_defaulted; + s/^\s+// && next; + s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last; my ($opt,$sep) = ($1,$2); my $val; if ("?" eq $sep) { @@ -1618,59 +1870,83 @@ sub parse_options { if /^\S/; #&dump_option($opt); } elsif ($sep !~ /\S/) { - $val = "1"; + $val_defaulted = 1; + $val = "1"; # this is an evil default; make 'em set it! } elsif ($sep eq "=") { - s/^(\S*)($|\s+)//; + + if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { + my $quote = $1; + ($val = $2) =~ s/\\([$quote\\])/$1/g; + } else { + s/^(\S*)//; $val = $1; + print OUT qq(Option better cleared using $opt=""\n) + unless length $val; + } + } else { #{ to "let some poor schmuck bounce on the % key in B<vi>." my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #} s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or print($OUT "Unclosed option value `$opt$sep$_'\n"), last; - $val = $1; - $val =~ s/\\([\\$end])/$1/g; + ($val = $1) =~ s/\\([\\$end])/$1/g; } - my ($option); - my $matches = - grep( /^\Q$opt/ && ($option = $_), @options ); - $matches = grep( /^\Q$opt/i && ($option = $_), @options ) - unless $matches; - print $OUT "Unknown option `$opt'\n" unless $matches; - print $OUT "Ambiguous option `$opt'\n" if $matches > 1; - $option{$option} = $val if $matches == 1 and defined $val; - eval "local \$frame = 0; local \$doret = -2; - require '$optionRequire{$option}'" - if $matches == 1 and defined $optionRequire{$option} and defined $val; - $ {$optionVars{$option}} = $val - if $matches == 1 - and defined $optionVars{$option} and defined $val; - & {$optionAction{$option}} ($val) - if $matches == 1 - and defined $optionAction{$option} - and defined &{$optionAction{$option}} and defined $val; - &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile - s/^\s+//; + + my $option; + my $matches = grep( /^\Q$opt/ && ($option = $_), @options ) + || grep( /^\Q$opt/i && ($option = $_), @options ); + + print($OUT "Unknown option `$opt'\n"), next unless $matches; + print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1; + + if ($opt_needs_val{$option} && $val_defaulted) { + print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n"; + next; + } + + $option{$option} = $val if defined $val; + + eval qq{ + local \$frame = 0; + local \$doret = -2; + require '$optionRequire{$option}'; + 1; + } || die # XXX: shouldn't happen + if defined $optionRequire{$option} && + defined $val; + + ${$optionVars{$option}} = $val + if defined $optionVars{$option} && + defined $val; + + &{$optionAction{$option}} ($val) + if defined $optionAction{$option} && + defined &{$optionAction{$option}} && + defined $val; + + # Not $rcfile + dump_option($option) unless $OUT eq \*STDERR; } } sub set_list { my ($stem,@list) = @_; my $val; - $ENV{"$ {stem}_n"} = @list; + $ENV{"${stem}_n"} = @list; for $i (0 .. $#list) { $val = $list[$i]; $val =~ s/\\/\\\\/g; $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg; - $ENV{"$ {stem}_$i"} = $val; + $ENV{"${stem}_$i"} = $val; } } sub get_list { my $stem = shift; my @list; - my $n = delete $ENV{"$ {stem}_n"}; + my $n = delete $ENV{"${stem}_n"}; my $val; for $i (0 .. $n - 1) { - $val = delete $ENV{"$ {stem}_$i"}; + $val = delete $ENV{"${stem}_$i"}; $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge; push @list, $val; } @@ -1734,7 +2010,7 @@ sub RemotePort { } sub tkRunning { - if ($ {$term->Features}{tkRunning}) { + if (${$term->Features}{tkRunning}) { return $term->tkRunning(@_); } else { print $OUT "tkRunning not supported by current ReadLine package.\n"; @@ -1796,7 +2072,7 @@ sub LineInfo { return $lineinfo unless @_; $lineinfo = shift; my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo"; - $emacs = ($stream =~ /^\|/); + $slave_editor = ($stream =~ /^\|/); open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write"); $LINEINFO = \*LINEINFO; my $save = select($LINEINFO); @@ -1814,8 +2090,8 @@ sub list_versions { s,/,::,g ; s/^perl5db$/DB/; s/^Term::ReadLine::readline$/readline/; - if (defined $ { $_ . '::VERSION' }) { - $version{$file} = "$ { $_ . '::VERSION' } from "; + if (defined ${ $_ . '::VERSION' }) { + $version{$file} = "${ $_ . '::VERSION' } from "; } $version{$file} .= $INC{$file}; } @@ -1823,6 +2099,10 @@ sub list_versions { } sub sethelp { + # XXX: make sure these are tabs between the command and explantion, + # or print_help will screw up your formatting if you have + # eeevil ornaments enabled. This is an insane mess. + $help = " B<T> Stack trace. B<s> [I<expr>] Single step [in I<expr>]. @@ -1884,39 +2164,16 @@ B<x> I<expr> Evals expression in array context, dumps the result. B<m> I<expr> Evals expression in array context, prints methods callable on the first element of the result. B<m> I<class> Prints methods callable via the given class. -B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... - Set or query values of options. I<val> defaults to 1. I<opt> can - be abbreviated. Several options can be listed. - I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell; - I<pager>: program for output of \"|cmd\"; - I<tkRunning>: run Tk while prompting (with ReadLine); - I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity; - I<inhibit_exit> Allows stepping off the end of the script. - I<ImmediateStop> Debugger should stop as early as possible. - I<RemotePort>: Remote hostname:port for remote debugging - The following options affect what happens with B<V>, B<X>, and B<x> commands: - I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all); - I<compactDump>, I<veryCompact>: change style of array and hash dump; - I<globPrint>: whether to print contents of globs; - I<DumpDBFiles>: dump arrays holding debugged files; - I<DumpPackages>: dump symbol tables of packages; - I<DumpReused>: dump contents of \"reused\" addresses; - I<quote>, I<HighBit>, I<undefPrint>: change style of string dump; - I<bareStringify>: Do not print the overload-stringified value; - Option I<PrintRet> affects printing of return value after B<r> command, - I<frame> affects printing messages on entry and exit from subroutines. - I<AutoTrace> affects printing messages on every possible breaking point. - I<maxTraceLen> gives maximal length of evals/args listed in stack trace. - I<ornaments> affects screen appearance of the command line. - During startup options are initialized from \$ENV{PERLDB_OPTS}. - You can put additional initialization options I<TTY>, I<noTTY>, - I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use - `B<R>' after you set them). + +B<<> ? List Perl commands to run before each prompt. B<<> I<expr> Define Perl command to run before each prompt. B<<<> I<expr> Add to the list of Perl commands to run before each prompt. +B<>> ? List Perl commands to run after each prompt. B<>> I<expr> Define Perl command to run after each prompt. B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. B<{> I<db_command> Define debugger command to run before each prompt. +B<{> ? List debugger commands to run before each prompt. +B<<> I<expr> Define Perl command to run before each prompt. B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. B<$prc> I<number> Redo a previous command (default previous command). B<$prc> I<-number> Redo number'th-to-last command. @@ -1938,13 +2195,49 @@ B<R> Pure-man-restart of debugger, some of debugger state Currently the following setting are preserved: history, breakpoints and actions, debugger B<O>ptions and the following command-line options: I<-w>, I<-I>, I<-e>. + +B<O> [I<opt>] ... Set boolean option to true +B<O> [I<opt>B<?>] Query options +B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... + Set options. Use quotes in spaces in value. + I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell; + I<pager> program for output of \"|cmd\"; + I<tkRunning> run Tk while prompting (with ReadLine); + I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity; + I<inhibit_exit> Allows stepping off the end of the script. + I<ImmediateStop> Debugger should stop as early as possible. + I<RemotePort> Remote hostname:port for remote debugging + The following options affect what happens with B<V>, B<X>, and B<x> commands: + I<arrayDepth>, I<hashDepth> print only first N elements ('' for all); + I<compactDump>, I<veryCompact> change style of array and hash dump; + I<globPrint> whether to print contents of globs; + I<DumpDBFiles> dump arrays holding debugged files; + I<DumpPackages> dump symbol tables of packages; + I<DumpReused> dump contents of \"reused\" addresses; + I<quote>, I<HighBit>, I<undefPrint> change style of string dump; + I<bareStringify> Do not print the overload-stringified value; + Other options include: + I<PrintRet> affects printing of return value after B<r> command, + I<frame> affects printing messages on entry and exit from subroutines. + I<AutoTrace> affects printing messages on every possible breaking point. + I<maxTraceLen> gives maximal length of evals/args listed in stack trace. + I<ornaments> affects screen appearance of the command line. + During startup options are initialized from \$ENV{PERLDB_OPTS}. + You can put additional initialization options I<TTY>, I<noTTY>, + I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use + `B<R>' after you set them). + +B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. - Complete description of debugger is available in B<perldebug> - section of Perl documention B<h h> Summary of debugger commands. -B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. +B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the + named Perl I<manpage>, or on B<$doccmd> itself if omitted. + Set B<\$DB::doccmd> to change viewer. + +Type `|h' for a paged display if this was too hard to read. + +"; # Fix balance of vi % matching: } }} -"; $summary = <<"END_SUM"; I<List/search source lines:> I<Control script execution:> B<l> [I<ln>|I<sub>] List source code B<T> Stack trace @@ -1968,18 +2261,71 @@ I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B< B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". -I<More help for> B<db_cmd>I<:> Type B<h> I<cmd_letter> Run B<perldoc perldebug> for more help. +For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs. END_SUM - # ')}}; # Fix balance of Emacs parsing + # ')}}; # Fix balance of vi % matching } sub print_help { - my $message = shift; - if (@Term::ReadLine::TermCap::rl_term_set) { - $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g; - $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g; - } - print $OUT $message; + local $_ = shift; + + # Restore proper alignment destroyed by eeevil I<> and B<> + # ornaments: A pox on both their houses! + # + # A help command will have everything up to and including + # the first tab sequence paddeed into a field 16 (or if indented 20) + # wide. If it's wide than that, an extra space will be added. + s{ + ^ # only matters at start of line + ( \040{4} | \t )* # some subcommands are indented + ( < ? # so <CR> works + [BI] < [^\t\n] + ) # find an eeevil ornament + ( \t+ ) # original separation, discarded + ( .* ) # this will now start (no earlier) than + # column 16 + } { + my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4); + my $clean = $command; + $clean =~ s/[BI]<([^>]*)>/$1/g; + # replace with this whole string: + (length($leadwhite) ? " " x 4 : "") + . $command + . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ") + . $text; + + }mgex; + + s{ # handle bold ornaments + B < ( [^>] + | > ) > + } { + $Term::ReadLine::TermCap::rl_term_set[2] + . $1 + . $Term::ReadLine::TermCap::rl_term_set[3] + }gex; + + s{ # handle italic ornaments + I < ( [^>] + | > ) > + } { + $Term::ReadLine::TermCap::rl_term_set[0] + . $1 + . $Term::ReadLine::TermCap::rl_term_set[1] + }gex; + + print $OUT $_; +} + +sub fix_less { + return if defined $ENV{LESS} && $ENV{LESS} =~ /r/; + my $is_less = $pager =~ /\bless\b/; + if ($pager =~ /\bmore\b/) { + my @st_more = stat('/usr/bin/more'); + my @st_less = stat('/usr/bin/less'); + $is_less = @st_more && @st_less + && $st_more[0] == $st_less[0] + && $st_more[1] == $st_less[1]; + } + # changes environment! + $ENV{LESS} .= 'r' if $is_less; } sub diesignal { @@ -2030,8 +2376,10 @@ sub dbdie { } eval { require Carp } if defined $^S; # If error/warning during compilation, # require may be broken. + die(@_, "\nCannot print stack trace, load with -MCarp option to see stack") unless defined &Carp::longmess; + # We do not want to debug this chunk (automatic disabling works # inside DB::DB, but not in Carp). my ($mysingle,$mytrace) = ($single,$trace); @@ -2138,18 +2486,81 @@ sub methods_via { my $prefix = shift; my $prepend = $prefix ? "via $prefix: " : ''; my $name; - for $name (grep {defined &{$ {"$ {class}::"}{$_}}} - sort keys %{"$ {class}::"}) { + for $name (grep {defined &{${"${class}::"}{$_}}} + sort keys %{"${class}::"}) { next if $seen{ $name }++; print $DB::OUT "$prepend$name\n"; } return unless shift; # Recurse? - for $name (@{"$ {class}::ISA"}) { + for $name (@{"${class}::ISA"}) { $prepend = $prefix ? $prefix . " -> $name" : $name; methods_via($name, $prepend, 1); } } +sub setman { + $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s + ? "man" # O Happy Day! + : "perldoc"; # Alas, poor unfortunates +} + +sub runman { + my $page = shift; + unless ($page) { + &system("$doccmd $doccmd"); + return; + } + # this way user can override, like with $doccmd="man -Mwhatever" + # or even just "man " to disable the path check. + unless ($doccmd eq 'man') { + &system("$doccmd $page"); + return; + } + + $page = 'perl' if lc($page) eq 'help'; + + require Config; + my $man1dir = $Config::Config{'man1dir'}; + my $man3dir = $Config::Config{'man3dir'}; + for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ } + my $manpath = ''; + $manpath .= "$man1dir:" if $man1dir =~ /\S/; + $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir; + chop $manpath if $manpath; + # harmless if missing, I figure + my $oldpath = $ENV{MANPATH}; + $ENV{MANPATH} = $manpath if $manpath; + my $nopathopt = $^O =~ /dunno what goes here/; + if (system($doccmd, + # I just *know* there are men without -M + (($manpath && !$nopathopt) ? ("-M", $manpath) : ()), + split ' ', $page) ) + { + unless ($page =~ /^perl\w/) { + if (grep { $page eq $_ } qw{ + 5004delta 5005delta amiga api apio book boot bot call compile + cygwin data dbmfilter debug debguts delta diag doc dos dsc embed + faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork + form func guts hack hist hpux intern ipc lexwarn locale lol mod + modinstall modlib number obj op opentut os2 os390 pod port + ref reftut run sec style sub syn thrtut tie toc todo toot tootc + trap unicode var vms win32 xs xstut + }) + { + $page =~ s/^/perl/; + system($doccmd, + (($manpath && !$nopathopt) ? ("-M", $manpath) : ()), + $page); + } + } + } + if (defined $oldpath) { + $ENV{MANPATH} = $manpath; + } else { + delete $ENV{MANPATH}; + } +} + # The following BEGIN is very handy if debugger goes havoc, debugging debugger? BEGIN { # This does not compile, alas. @@ -2187,7 +2598,7 @@ sub db_complete { # Specific code for b c l V m f O, &blah, $blah, @blah, %blah my($text, $line, $start) = @_; my ($itext, $search, $prefix, $pack) = - ($text, "^\Q$ {'package'}::\E([^:]+)\$"); + ($text, "^\Q${'package'}::\E([^:]+)\$"); return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines (map { /$search/ ? ($1) : () } keys %sub) diff --git a/lib/strict.pm b/lib/strict.pm index f9d60af154..042227f967 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -34,6 +34,8 @@ use symbolic references (see L<perlref>). print $$ref; # ok $ref = "foo"; print $$ref; # runtime error; normally ok + $file = "STDOUT"; + print $file "Hi!"; # error; note: no comma after $file =item C<strict vars> diff --git a/lib/syslog.pl b/lib/syslog.pl index 9e03399e4d..70c439b9ae 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -29,10 +29,12 @@ package syslog; +use warnings::register; + $host = 'localhost' unless $host; # set $syslog'host to change -if ($] >= 5) { - warn "You should 'use Sys::Syslog' instead; continuing" # if $^W +if ($] >= 5 && warnings::enabled()) { + warnings::warn "You should 'use Sys::Syslog' instead; continuing"; } require 'syslog.ph'; diff --git a/lib/unicode/Is/Alnum.pl b/lib/unicode/Is/Alnum.pl index d44f744e20..203860bac1 100644 --- a/lib/unicode/Is/Alnum.pl +++ b/lib/unicode/Is/Alnum.pl @@ -10,11 +10,7 @@ return <<'END'; 00ba 00c0 00d6 00d8 00f6 -00f8 01c4 -01c6 01c7 -01c9 01ca -01cc 01f1 -01f3 021f +00f8 021f 0222 0233 0250 02ad 0386 @@ -210,19 +206,16 @@ return <<'END'; 1f5b 1f5d 1f5f 1f7d -1f80 1f87 -1f90 1f97 -1fa0 1fa7 -1fb0 1fb4 -1fb6 1fbb +1f80 1fb4 +1fb6 1fbc 1fbe 1fc2 1fc4 -1fc6 1fcb +1fc6 1fcc 1fd0 1fd3 1fd6 1fdb 1fe0 1fec 1ff2 1ff4 -1ff6 1ffb +1ff6 1ffc 207f 2102 2107 diff --git a/lib/unicode/Is/Alpha.pl b/lib/unicode/Is/Alpha.pl index 0e94688e85..90020b8fb6 100644 --- a/lib/unicode/Is/Alpha.pl +++ b/lib/unicode/Is/Alpha.pl @@ -9,11 +9,7 @@ return <<'END'; 00ba 00c0 00d6 00d8 00f6 -00f8 01c4 -01c6 01c7 -01c9 01ca -01cc 01f1 -01f3 021f +00f8 021f 0222 0233 0250 02ad 0386 @@ -193,19 +189,16 @@ return <<'END'; 1f5b 1f5d 1f5f 1f7d -1f80 1f87 -1f90 1f97 -1fa0 1fa7 -1fb0 1fb4 -1fb6 1fbb +1f80 1fb4 +1fb6 1fbc 1fbe 1fc2 1fc4 -1fc6 1fcb +1fc6 1fcc 1fd0 1fd3 1fd6 1fdb 1fe0 1fec 1ff2 1ff4 -1ff6 1ffb +1ff6 1ffc 207f 2102 2107 diff --git a/lib/unicode/Is/LbrkAI.pl b/lib/unicode/Is/LbrkAI.pl new file mode 100644 index 0000000000..a15f76014e --- /dev/null +++ b/lib/unicode/Is/LbrkAI.pl @@ -0,0 +1,139 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +00a1 +00a7 00a8 +00aa +00b2 00b3 +00b6 00ba +00bc 00bf +00c6 +00d0 +00d7 00d8 +00de 00e1 +00e6 +00e8 00ea +00ec 00ed +00f0 +00f2 00f3 +00f7 00fa +00fc +00fe +0101 +0111 +0113 +011b +0126 0127 +012b +0131 0133 +0138 +013f 0142 +0144 +0148 014a +014d +0152 0153 +0166 0167 +016b +01ce +01d0 +01d2 +01d4 +01d6 +01d8 +01da +01dc +0251 +0261 +02c7 +02c9 02cb +02cd +02d0 +02d8 02db +02dd +0391 03a1 +03a3 03a9 +03b1 03c1 +03c3 03c9 +0401 +0410 044f +0451 +2016 +2020 2021 +203b +2074 +207f +2081 2084 +2105 +2113 +2121 2122 +212b +2154 2155 +215b +215e +2160 216b +2170 2179 +2190 2199 +21d2 +21d4 +2200 +2202 2203 +2207 2208 +220b +220f +2211 +2215 +221a +221d 2220 +2223 +2225 +2227 222c +222e +2234 2237 +223c 223d +2248 +224c +2252 +2260 2261 +2264 2267 +226a 226b +226e 226f +2282 2283 +2286 2287 +2295 +2299 +22a5 +22bf +2312 +2460 24bf +24d0 24e9 +2500 254b +2550 2574 +2580 258f +2592 2595 +25a0 25a1 +25a3 25a9 +25b2 25b3 +25b6 25b7 +25bc 25bd +25c0 25c1 +25c6 25c7 +25cb +25ce 25d1 +25e2 25e5 +25ef +2605 2606 +2609 +260e 260f +261c +261e +2640 +2642 +2660 2661 +2663 2665 +2667 266a +266c 266d +266f +e000 f8ff +fffd +END diff --git a/lib/unicode/Is/LbrkAL.pl b/lib/unicode/Is/LbrkAL.pl new file mode 100644 index 0000000000..c705dc8a3d --- /dev/null +++ b/lib/unicode/Is/LbrkAL.pl @@ -0,0 +1,387 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0023 +0026 +002a +003c 003e +0040 005a +005e 007a +007e +00a6 +00a9 +00ac +00ae 00af +00b5 +00c0 00c5 +00c7 00cf +00d1 00d6 +00d9 00dd +00e2 00e5 +00e7 +00eb +00ee 00ef +00f1 +00f4 00f6 +00fb +00fd +00ff 0100 +0102 0110 +0112 +0114 011a +011c 0125 +0128 012a +012c 0130 +0134 0137 +0139 013e +0143 +0145 0147 +014b 014c +014e 0151 +0154 0165 +0168 016a +016c 01cd +01cf +01d1 +01d3 +01d5 +01d7 +01d9 +01db +01dd 021f +0222 0233 +0250 +0252 0260 +0262 02ad +02b0 02c6 +02ce 02cf +02d1 02d7 +02dc +02de 02ee +0374 0375 +037a +037e +0384 038a +038c +038e 0390 +03aa 03b0 +03c2 +03ca 03ce +03d0 03d7 +03da 03f3 +0400 +0402 040f +0450 +0452 0482 +048c 04c4 +04c7 04c8 +04cb 04cc +04d0 04f5 +04f8 04f9 +0531 0556 +0559 055f +0561 0587 +05be +05c0 +05c3 +05d0 05ea +05f0 05f4 +060c +061b +061f +0621 063a +0640 064a +066a 066d +0671 06d5 +06e5 06e6 +06e9 +06fa 06fe +0700 070d +0710 +0712 072c +0780 07a5 +0905 0939 +093d +0950 +0958 0961 +0964 0965 +0970 +0985 098c +098f 0990 +0993 09a8 +09aa 09b0 +09b2 +09b6 09b9 +09dc 09dd +09df 09e1 +09f0 09f1 +09f4 09fa +0a05 0a0a +0a0f 0a10 +0a13 0a28 +0a2a 0a30 +0a32 0a33 +0a35 0a36 +0a38 0a39 +0a59 0a5c +0a5e +0a72 0a74 +0a85 0a8b +0a8d +0a8f 0a91 +0a93 0aa8 +0aaa 0ab0 +0ab2 0ab3 +0ab5 0ab9 +0abd +0ad0 +0ae0 +0b05 0b0c +0b0f 0b10 +0b13 0b28 +0b2a 0b30 +0b32 0b33 +0b36 0b39 +0b3d +0b5c 0b5d +0b5f 0b61 +0b70 +0b85 0b8a +0b8e 0b90 +0b92 0b95 +0b99 0b9a +0b9c +0b9e 0b9f +0ba3 0ba4 +0ba8 0baa +0bae 0bb5 +0bb7 0bb9 +0bf0 0bf2 +0c05 0c0c +0c0e 0c10 +0c12 0c28 +0c2a 0c33 +0c35 0c39 +0c60 0c61 +0c85 0c8c +0c8e 0c90 +0c92 0ca8 +0caa 0cb3 +0cb5 0cb9 +0cde +0ce0 0ce1 +0d05 0d0c +0d0e 0d10 +0d12 0d28 +0d2a 0d39 +0d60 0d61 +0d85 0d96 +0d9a 0db1 +0db3 0dbb +0dbd +0dc0 0dc6 +0df4 +0e4f +0f00 0f0a +0f0d 0f17 +0f1a 0f1f +0f2a 0f34 +0f36 +0f38 +0f40 0f47 +0f49 0f6a +0f85 +0f88 0f8b +0fbe 0fc5 +0fc7 0fcc +0fcf +104a 104f +10a0 10c5 +10d0 10f6 +10fb +1200 1206 +1208 1246 +1248 +124a 124d +1250 1256 +1258 +125a 125d +1260 1286 +1288 +128a 128d +1290 12ae +12b0 +12b2 12b5 +12b8 12be +12c0 +12c2 12c5 +12c8 12ce +12d0 12d6 +12d8 12ee +12f0 130e +1310 +1312 1315 +1318 131e +1320 1346 +1348 135a +1362 1368 +1372 137c +13a0 13f4 +1401 1676 +1681 169a +16a0 16f0 +17dc +1800 1805 +1807 180a +1820 1877 +1880 18a8 +1e00 1e9b +1ea0 1ef9 +1f00 1f15 +1f18 1f1d +1f20 1f45 +1f48 1f4d +1f50 1f57 +1f59 +1f5b +1f5d +1f5f 1f7d +1f80 1fb4 +1fb6 1fc4 +1fc6 1fd3 +1fd6 1fdb +1fdd 1fef +1ff2 1ff4 +1ff6 1ffe +2015 +2017 +2022 2023 +2038 +203d 2043 +2048 204d +2070 +2075 207c +2080 +2085 208c +2100 2102 +2104 +2106 2108 +210a 2112 +2114 2115 +2117 2120 +2123 2125 +2127 212a +212c 213a +2153 +2156 215a +215c 215d +215f +216c 216f +217a 2183 +219a 21d1 +21d3 +21d5 21f3 +2201 +2204 2206 +2209 220a +220c 220e +2210 +2214 +2216 2219 +221b 221c +2221 2222 +2224 +2226 +222d +222f 2233 +2238 223b +223e 2247 +2249 224b +224d 2251 +2253 225f +2262 2263 +2268 2269 +226c 226d +2270 2281 +2284 2285 +2288 2294 +2296 2298 +229a 22a4 +22a6 22be +22c0 22f1 +2300 2311 +2313 2328 +232b 237b +237d 239a +2400 2426 +2440 244a +24c0 24cf +24ea +254c 254f +2575 257f +2590 2591 +25a2 +25aa 25b1 +25b4 25b5 +25b8 25bb +25be 25bf +25c2 25c5 +25c8 25ca +25cc 25cd +25d2 25e1 +25e6 25ee +25f0 25f7 +2600 2604 +2607 2608 +260a 260d +2610 2613 +2619 261b +261d +261f 263f +2641 +2643 265f +2662 +2666 +266b +266e +2670 2671 +2701 2704 +2706 2709 +270c 2727 +2729 274b +274d +274f 2752 +2756 +2758 275e +2761 2767 +2776 2794 +2798 27af +27b1 27be +2800 28ff +fb00 fb06 +fb13 fb17 +fb1d +fb1f fb36 +fb38 fb3c +fb3e +fb40 fb41 +fb43 fb44 +fb46 fbb1 +fbd3 fd3d +fd50 fd8f +fd92 fdc7 +fdf0 fdfb +fe6b +fe70 fe72 +fe74 +fe76 fefc +ff66 +ff71 ff9d +ffa0 ffbe +ffc2 ffc7 +ffca ffcf +ffd2 ffd7 +ffda ffdc +ffe8 ffee +END diff --git a/lib/unicode/Is/LbrkB2.pl b/lib/unicode/Is/LbrkB2.pl new file mode 100644 index 0000000000..527e4c8977 --- /dev/null +++ b/lib/unicode/Is/LbrkB2.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +2014 +END diff --git a/lib/unicode/Is/LbrkBA.pl b/lib/unicode/Is/LbrkBA.pl new file mode 100644 index 0000000000..053369bccc --- /dev/null +++ b/lib/unicode/Is/LbrkBA.pl @@ -0,0 +1,19 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0009 +007c +00ad +00b4 +058a +0f0b +1361 +1680 +17d5 +2000 2006 +2008 200a +2010 +2012 2013 +2027 +END diff --git a/lib/unicode/Is/LbrkBB.pl b/lib/unicode/Is/LbrkBB.pl new file mode 100644 index 0000000000..5d3952a25d --- /dev/null +++ b/lib/unicode/Is/LbrkBB.pl @@ -0,0 +1,8 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +02c8 +02cc +1806 +END diff --git a/lib/unicode/Is/LbrkBK.pl b/lib/unicode/Is/LbrkBK.pl new file mode 100644 index 0000000000..2c314fb0ba --- /dev/null +++ b/lib/unicode/Is/LbrkBK.pl @@ -0,0 +1,7 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +000c +2028 2029 +END diff --git a/lib/unicode/Is/LbrkCB.pl b/lib/unicode/Is/LbrkCB.pl new file mode 100644 index 0000000000..95f8b803dc --- /dev/null +++ b/lib/unicode/Is/LbrkCB.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +fffc +END diff --git a/lib/unicode/Is/LbrkCL.pl b/lib/unicode/Is/LbrkCL.pl new file mode 100644 index 0000000000..a73130a6bd --- /dev/null +++ b/lib/unicode/Is/LbrkCL.pl @@ -0,0 +1,47 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0029 +005d +007d +0f3b +0f3d +169c +2046 +207e +208e +232a +3001 3002 +3009 +300b +300d +300f +3011 +3015 +3017 +3019 +301b +301e 301f +fd3f +fe36 +fe38 +fe3a +fe3c +fe3e +fe40 +fe42 +fe44 +fe50 +fe52 +fe5a +fe5c +fe5e +ff09 +ff0c +ff0e +ff3d +ff5d +ff61 +ff63 ff64 +END diff --git a/lib/unicode/Is/LbrkCM.pl b/lib/unicode/Is/LbrkCM.pl new file mode 100644 index 0000000000..3d0f3474f8 --- /dev/null +++ b/lib/unicode/Is/LbrkCM.pl @@ -0,0 +1,117 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0000 0008 +000b +000e 001f +007f 009f +0300 034e +0360 0362 +0483 0486 +0488 0489 +0591 05a1 +05a3 05b9 +05bb 05bd +05bf +05c1 05c2 +05c4 +064b 0655 +0670 +06d6 06e4 +06e7 06e8 +06ea 06ed +070f +0711 +0730 074a +07a6 07b0 +0901 0903 +093c +093e 094d +0951 0954 +0962 0963 +0981 0983 +09bc +09be 09c4 +09c7 09c8 +09cb 09cd +09d7 +09e2 09e3 +0a02 +0a3c +0a3e 0a42 +0a47 0a48 +0a4b 0a4d +0a70 0a71 +0a81 0a83 +0abc +0abe 0ac5 +0ac7 0ac9 +0acb 0acd +0b01 0b03 +0b3c +0b3e 0b43 +0b47 0b48 +0b4b 0b4d +0b56 0b57 +0b82 0b83 +0bbe 0bc2 +0bc6 0bc8 +0bca 0bcd +0bd7 +0c01 0c03 +0c3e 0c44 +0c46 0c48 +0c4a 0c4d +0c55 0c56 +0c82 0c83 +0cbe 0cc4 +0cc6 0cc8 +0cca 0ccd +0cd5 0cd6 +0d02 0d03 +0d3e 0d43 +0d46 0d48 +0d4a 0d4d +0d57 +0d82 0d83 +0dca +0dcf 0dd4 +0dd6 +0dd8 0ddf +0df2 0df3 +0e31 +0e34 0e3a +0e47 0e4e +0eb1 +0eb4 0eb9 +0ebb 0ebc +0ec8 0ecd +0f18 0f19 +0f35 +0f37 +0f39 +0f3e 0f3f +0f71 0f84 +0f86 0f87 +0f90 0f97 +0f99 0fbc +0fc6 +102c 1032 +1036 1039 +1056 1059 +1160 11a2 +11a8 11f9 +17b4 17d3 +180b 180e +18a9 +200c 200f +202a 202e +206a 206f +20d0 20e3 +302a 302f +3099 309a +fb1e +fe20 fe23 +fff9 fffb +END diff --git a/lib/unicode/Is/LbrkCR.pl b/lib/unicode/Is/LbrkCR.pl new file mode 100644 index 0000000000..c61a527902 --- /dev/null +++ b/lib/unicode/Is/LbrkCR.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +000d +END diff --git a/lib/unicode/Is/LbrkEX.pl b/lib/unicode/Is/LbrkEX.pl new file mode 100644 index 0000000000..d847092dce --- /dev/null +++ b/lib/unicode/Is/LbrkEX.pl @@ -0,0 +1,10 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0021 +003f +fe56 fe57 +ff01 +ff1f +END diff --git a/lib/unicode/Is/LbrkGL.pl b/lib/unicode/Is/LbrkGL.pl new file mode 100644 index 0000000000..b03a627c2b --- /dev/null +++ b/lib/unicode/Is/LbrkGL.pl @@ -0,0 +1,11 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +00a0 +0f0c +2007 +2011 +202f +feff +END diff --git a/lib/unicode/Is/LbrkHY.pl b/lib/unicode/Is/LbrkHY.pl new file mode 100644 index 0000000000..6989bc8631 --- /dev/null +++ b/lib/unicode/Is/LbrkHY.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +002d +END diff --git a/lib/unicode/Is/LbrkID.pl b/lib/unicode/Is/LbrkID.pl new file mode 100644 index 0000000000..0b1cc8453f --- /dev/null +++ b/lib/unicode/Is/LbrkID.pl @@ -0,0 +1,81 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +1100 1159 +115f +2e80 2e99 +2e9b 2ef3 +2f00 2fd5 +2ff0 2ffb +3000 +3003 3004 +3006 3007 +3012 3013 +3020 3029 +3030 303a +303e 303f +3042 +3044 +3046 +3048 +304a 3062 +3064 3082 +3084 +3086 +3088 308d +308f 3094 +30a2 +30a4 +30a6 +30a8 +30aa 30c2 +30c4 30e2 +30e4 +30e6 +30e8 30ed +30ef 30f4 +30f7 30fa +30fc +30fe +3105 312c +3131 318e +3190 31b7 +3200 321c +3220 3243 +3260 327b +327f 32b0 +32c0 32cb +32d0 32fe +3300 3376 +337b 33dd +33e0 33fe +3400 4db5 +4e00 9fa5 +a000 a48c +a490 a4a1 +a4a4 a4b3 +a4b5 a4c0 +a4c2 a4c4 +a4c6 +ac00 d7a3 +f900 fa2d +fe30 fe34 +fe49 fe4f +fe51 +fe58 +fe5f fe66 +fe68 +ff02 ff03 +ff06 ff07 +ff0a ff0b +ff0d +ff0f ff19 +ff1c ff1e +ff20 ff3a +ff3c +ff3e ff5a +ff5c +ff5e +ffe2 ffe4 +END diff --git a/lib/unicode/Is/LbrkIN.pl b/lib/unicode/Is/LbrkIN.pl new file mode 100644 index 0000000000..825198d12c --- /dev/null +++ b/lib/unicode/Is/LbrkIN.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +2024 2026 +END diff --git a/lib/unicode/Is/LbrkIS.pl b/lib/unicode/Is/LbrkIS.pl new file mode 100644 index 0000000000..afa01a8004 --- /dev/null +++ b/lib/unicode/Is/LbrkIS.pl @@ -0,0 +1,9 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +002c +002e +003a 003b +0589 +END diff --git a/lib/unicode/Is/LbrkLF.pl b/lib/unicode/Is/LbrkLF.pl new file mode 100644 index 0000000000..dcb5490eb2 --- /dev/null +++ b/lib/unicode/Is/LbrkLF.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +000a +END diff --git a/lib/unicode/Is/LbrkNS.pl b/lib/unicode/Is/LbrkNS.pl new file mode 100644 index 0000000000..af9f3371c9 --- /dev/null +++ b/lib/unicode/Is/LbrkNS.pl @@ -0,0 +1,41 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0e5a 0e5b +17d4 +17d6 17da +203c +2044 +3005 +301c +3041 +3043 +3045 +3047 +3049 +3063 +3083 +3085 +3087 +308e +309b 309e +30a1 +30a3 +30a5 +30a7 +30a9 +30c3 +30e3 +30e5 +30e7 +30ee +30f5 30f6 +30fb +30fd +fe54 fe55 +ff1a ff1b +ff65 +ff67 ff70 +ff9e ff9f +END diff --git a/lib/unicode/Is/LbrkNU.pl b/lib/unicode/Is/LbrkNU.pl new file mode 100644 index 0000000000..5c55d221b4 --- /dev/null +++ b/lib/unicode/Is/LbrkNU.pl @@ -0,0 +1,24 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0030 0039 +0660 0669 +06f0 06f9 +0966 096f +09e6 09ef +0a66 0a6f +0ae6 0aef +0b66 0b6f +0be7 0bef +0c66 0c6f +0ce6 0cef +0d66 0d6f +0e50 0e59 +0ed0 0ed9 +0f20 0f29 +1040 1049 +1369 1371 +17e0 17e9 +1810 1819 +END diff --git a/lib/unicode/Is/LbrkOP.pl b/lib/unicode/Is/LbrkOP.pl new file mode 100644 index 0000000000..a7dee379eb --- /dev/null +++ b/lib/unicode/Is/LbrkOP.pl @@ -0,0 +1,43 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0028 +005b +007b +0f3a +0f3c +169b +201a +201e +2045 +207d +208d +2329 +3008 +300a +300c +300e +3010 +3014 +3016 +3018 +301a +301d +fd3e +fe35 +fe37 +fe39 +fe3b +fe3d +fe3f +fe41 +fe43 +fe59 +fe5b +fe5d +ff08 +ff3b +ff5b +ff62 +END diff --git a/lib/unicode/Is/LbrkPO.pl b/lib/unicode/Is/LbrkPO.pl new file mode 100644 index 0000000000..cdfb56ea17 --- /dev/null +++ b/lib/unicode/Is/LbrkPO.pl @@ -0,0 +1,16 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0025 +00a2 +00b0 +2030 2037 +20a7 +2103 +2109 +2126 +fe6a +ff05 +ffe0 +END diff --git a/lib/unicode/Is/LbrkPR.pl b/lib/unicode/Is/LbrkPR.pl new file mode 100644 index 0000000000..c2d20da481 --- /dev/null +++ b/lib/unicode/Is/LbrkPR.pl @@ -0,0 +1,21 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0024 +002b +005c +00a3 00a5 +00b1 +09f2 09f3 +0e3f +17db +20a0 20a6 +20a8 20af +2116 +2212 2213 +fe69 +ff04 +ffe1 +ffe5 ffe6 +END diff --git a/lib/unicode/Is/LbrkQU.pl b/lib/unicode/Is/LbrkQU.pl new file mode 100644 index 0000000000..46a6ee3a07 --- /dev/null +++ b/lib/unicode/Is/LbrkQU.pl @@ -0,0 +1,13 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0022 +0027 +00ab +00bb +2018 2019 +201b 201d +201f +2039 203a +END diff --git a/lib/unicode/Is/LbrkSA.pl b/lib/unicode/Is/LbrkSA.pl new file mode 100644 index 0000000000..bae4ced946 --- /dev/null +++ b/lib/unicode/Is/LbrkSA.pl @@ -0,0 +1,30 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0e01 0e30 +0e32 0e33 +0e40 0e46 +0e81 0e82 +0e84 +0e87 0e88 +0e8a +0e8d +0e94 0e97 +0e99 0e9f +0ea1 0ea3 +0ea5 +0ea7 +0eaa 0eab +0ead 0eb0 +0eb2 0eb3 +0ebd +0ec0 0ec4 +0ec6 +0edc 0edd +1000 1021 +1023 1027 +1029 102a +1050 1055 +1780 17b3 +END diff --git a/lib/unicode/Is/LbrkSG.pl b/lib/unicode/Is/LbrkSG.pl new file mode 100644 index 0000000000..8888fb5f3c --- /dev/null +++ b/lib/unicode/Is/LbrkSG.pl @@ -0,0 +1,8 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +d800 db7f +db80 dbff +dc00 dfff +END diff --git a/lib/unicode/Is/LbrkSP.pl b/lib/unicode/Is/LbrkSP.pl new file mode 100644 index 0000000000..e786a0c935 --- /dev/null +++ b/lib/unicode/Is/LbrkSP.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +0020 +END diff --git a/lib/unicode/Is/LbrkSY.pl b/lib/unicode/Is/LbrkSY.pl new file mode 100644 index 0000000000..d2a33aeacc --- /dev/null +++ b/lib/unicode/Is/LbrkSY.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +002f +END diff --git a/lib/unicode/Is/LbrkXX.pl b/lib/unicode/Is/LbrkXX.pl new file mode 100644 index 0000000000..ec287c456a --- /dev/null +++ b/lib/unicode/Is/LbrkXX.pl @@ -0,0 +1,5 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +END diff --git a/lib/unicode/Is/LbrkZW.pl b/lib/unicode/Is/LbrkZW.pl new file mode 100644 index 0000000000..96d8e99efc --- /dev/null +++ b/lib/unicode/Is/LbrkZW.pl @@ -0,0 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! +return <<'END'; +200b +END diff --git a/lib/unicode/Is/Word.pl b/lib/unicode/Is/Word.pl index 23186bd27d..2f13b382af 100644 --- a/lib/unicode/Is/Word.pl +++ b/lib/unicode/Is/Word.pl @@ -11,11 +11,7 @@ return <<'END'; 00ba 00c0 00d6 00d8 00f6 -00f8 01c4 -01c6 01c7 -01c9 01ca -01cc 01f1 -01f3 021f +00f8 021f 0222 0233 0250 02ad 0386 @@ -211,19 +207,16 @@ return <<'END'; 1f5b 1f5d 1f5f 1f7d -1f80 1f87 -1f90 1f97 -1fa0 1fa7 -1fb0 1fb4 -1fb6 1fbb +1f80 1fb4 +1fb6 1fbc 1fbe 1fc2 1fc4 -1fc6 1fcb +1fc6 1fcc 1fd0 1fd3 1fd6 1fdb 1fe0 1fec 1ff2 1ff4 -1ff6 1ffb +1ff6 1ffc 207f 2102 2107 diff --git a/lib/unicode/mktables.PL b/lib/unicode/mktables.PL index cef6936b68..4f705a4016 100755 --- a/lib/unicode/mktables.PL +++ b/lib/unicode/mktables.PL @@ -11,9 +11,10 @@ mkdir "To", 0777; @todo = ( # typical - ['IsWord', '$cat =~ /^L[ulo]|^Nd/ or $code eq "005F"', ''], - ['IsAlnum', '$cat =~ /^L[ulo]|^Nd/', ''], - ['IsAlpha', '$cat =~ /^L[ulo]/', ''], + ['IsWord', '$cat =~ /^L[ulot]|^Nd/ or $code eq "005F"', ''], + ['IsAlnum', '$cat =~ /^L[ulot]|^Nd/', ''], + ['IsAlpha', '$cat =~ /^L[ulot]/', ''], + # XXX broken: recursive definition (/\s/ will look up IsSpace in future) ['IsSpace', '$cat =~ /^Z/ or $code lt "0020" and chr(hex $code) =~ /^\s/', ''], ['IsDigit', '$cat =~ /^Nd$/', ''], ['IsUpper', '$cat =~ /^Lu$/', ''], @@ -166,6 +167,40 @@ mkdir "To", 0777; ['IsSylWA', '$syl eq "A"', ''], ['IsSylWE', '$syl eq "E"', ''], ['IsSylWC', '$syl eq "C"', ''], + +# Line break properties - Normative + + ['IsLbrkBK','$brk eq "BK"', ''], # Mandatory Break + ['IsLbrkCR','$brk eq "CR"', ''], # Carriage Return + ['IsLbrkLF','$brk eq "LF"', ''], # Line Feed + ['IsLbrkCM','$brk eq "CM"', ''], # Attached Characters and Combining Marks + ['IsLbrkSG','$brk eq "SG"', ''], # Surrogates + ['IsLbrkGL','$brk eq "GL"', ''], # Non-breaking (Glue) + ['IsLbrkCB','$brk eq "CB"', ''], # Contingent Break Opportunity + ['IsLbrkSP','$brk eq "SP"', ''], # Space + ['IsLbrkZW','$brk eq "ZW"', ''], # Zero Width Space + +# Line break properties - Informative + ['IsLbrkXX','$brk eq "XX"', ''], # Unknown + ['IsLbrkOP','$brk eq "OP"', ''], # Opening Punctuation + ['IsLbrkCL','$brk eq "CL"', ''], # Closing Punctuation + ['IsLbrkQU','$brk eq "QU"', ''], # Ambiguous Quotation + ['IsLbrkNS','$brk eq "NS"', ''], # Non Starter + ['IsLbrkEX','$brk eq "EX"', ''], # Exclamation/Interrogation + ['IsLbrkSY','$brk eq "SY"', ''], # Symbols Allowing Breaks + ['IsLbrkIS','$brk eq "IS"', ''], # Infix Separator (Numeric) + ['IsLbrkPR','$brk eq "PR"', ''], # Prefix (Numeric) + ['IsLbrkPO','$brk eq "PO"', ''], # Postfix (Numeric) + ['IsLbrkNU','$brk eq "NU"', ''], # Numeric + ['IsLbrkAL','$brk eq "AL"', ''], # Ordinary Alphabetic and Symbol Characters + ['IsLbrkID','$brk eq "ID"', ''], # Ideographic + ['IsLbrkIN','$brk eq "IN"', ''], # Inseparable + ['IsLbrkHY','$brk eq "HY"', ''], # Hyphen + ['IsLbrkBB','$brk eq "BB"', ''], # Break Opportunity Before + ['IsLbrkBA','$brk eq "BA"', ''], # Break Opportunity After + ['IsLbrkSA','$brk eq "SA"', ''], # Complex Context (South East Asian) + ['IsLbrkAI','$brk eq "AI"', ''], # Ambiguous (Alphabetic or Ideographic) + ['IsLbrkB2','$brk eq "B2"', ''], # Break Opportunity Before and After ); # This is not written for speed... @@ -257,6 +292,11 @@ sub proplist { $split = '($code, $short, $syl) = split(/; */); $code =~ s/^U\+//;'; } + elsif ($table =~ /^IsLbrk/) { + open(UD, "LineBrk.txt") or warn "Can't open $table: $!"; + + $split = '($code, $brk, $name) = split(/;/);'; + } else { open(UD, $UnicodeData) or warn "Can't open $UnicodeData: $!"; diff --git a/lib/vars.pm b/lib/vars.pm index 6ae5373f89..0ace55169c 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -9,6 +9,8 @@ require 5.002; # We'll let those bugs get found on the development track. require Carp if $] < 5.00450; +use warnings::register; + sub import { my $callpack = caller; my ($pack, @imports, $sym, $ch) = @_; @@ -22,9 +24,8 @@ sub import { } elsif ($sym =~ /^\w+[[{].*[]}]$/) { require Carp; Carp::croak("Can't declare individual elements of hash or array"); - } elsif ($^W and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { - require Carp; - Carp::carp("No need to declare built-in vars"); + } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { + warnings::warn("No need to declare built-in vars"); } } *{"${callpack}::$sym"} = diff --git a/lib/warnings.pm b/lib/warnings.pm index 11fd5b0718..11558d50d4 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -17,7 +17,12 @@ warnings - Perl pragma to control optional warnings use warnings "all"; no warnings "all"; - if (warnings::enabled("void") { + use warnings::register; + if (warnings::enabled()) { + warnings::warn("some warning"); + } + + if (warnings::enabled("void")) { warnings::warn("void", "some warning"); } @@ -26,23 +31,33 @@ warnings - Perl pragma to control optional warnings If no import list is supplied, all possible warnings are either enabled or disabled. -Two functions are provided to assist module authors. +A number of functions are provided to assist module authors. =over 4 -=item warnings::enabled($category) +=item use warnings::register + +Creates a new warnings category which has the same name as the module +where the call to the pragma is used. -Returns TRUE if the warnings category in C<$category> is enabled in the -calling module. Otherwise returns FALSE. +=item warnings::enabled([$category]) +Returns TRUE if the warnings category C<$category> is enabled in the +calling module. Otherwise returns FALSE. -=item warnings::warn($category, $message) +If the parameter, C<$category>, isn't supplied, the current package name +will be used. + +=item warnings::warn([$category,] $message) If the calling module has I<not> set C<$category> to "FATAL", print C<$message> to STDERR. If the calling module has set C<$category> to "FATAL", print C<$message> STDERR then die. +If the parameter, C<$category>, isn't supplied, the current package name +will be used. + =back See L<perlmod/Pragmatic Modules> and L<perllexwarn>. @@ -51,107 +66,161 @@ See L<perlmod/Pragmatic Modules> and L<perllexwarn>. use Carp ; +%Offsets = ( + 'all' => 0, + 'chmod' => 2, + 'closure' => 4, + 'exiting' => 6, + 'glob' => 8, + 'io' => 10, + 'closed' => 12, + 'exec' => 14, + 'newline' => 16, + 'pipe' => 18, + 'unopened' => 20, + 'misc' => 22, + 'numeric' => 24, + 'once' => 26, + 'overflow' => 28, + 'pack' => 30, + 'portable' => 32, + 'recursion' => 34, + 'redefine' => 36, + 'regexp' => 38, + 'severe' => 40, + 'debugging' => 42, + 'inplace' => 44, + 'internal' => 46, + 'malloc' => 48, + 'signal' => 50, + 'substr' => 52, + 'syntax' => 54, + 'ambiguous' => 56, + 'bareword' => 58, + 'deprecated' => 60, + 'digit' => 62, + 'parenthesis' => 64, + 'precedence' => 66, + 'printf' => 68, + 'prototype' => 70, + 'qw' => 72, + 'reserved' => 74, + 'semicolon' => 76, + 'taint' => 78, + 'umask' => 80, + 'uninitialized' => 82, + 'unpack' => 84, + 'untie' => 86, + 'utf8' => 88, + 'void' => 90, + 'y2k' => 92, + ); + %Bits = ( - 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47] - 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27] - 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28] - 'chmod' => "\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0] - 'closed' => "\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5] - 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] - 'debugging' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20] - 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29] - 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30] - 'exec' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] - 'exiting' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] - 'glob' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'inplace' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21] - 'internal' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22] - 'io' => "\x00\x55\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9] - 'malloc' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23] - 'misc' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] - 'newline' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] - 'numeric' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] - 'once' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'overflow' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13] - 'pack' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14] - 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31] - 'pipe' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'portable' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15] - 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32] - 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33] - 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34] - 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35] - 'recursion' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16] - 'redefine' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17] - 'regexp' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18] - 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36] - 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37] - 'severe' => "\x00\x00\x00\x00\x40\x55\x00\x00\x00\x00\x00\x00", # [19..23] - 'signal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24] - 'substr' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25] - 'syntax' => "\x00\x00\x00\x00\x00\x00\x50\x55\x55\x05\x00\x00", # [26..37] - 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38] - 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39] - 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40] - 'unopened' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] - 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41] - 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44] - 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45] + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29] + 'chmod' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'debugging' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21] + 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'inplace' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22] + 'internal' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23] + 'io' => "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24] + 'misc' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'newline' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'numeric' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'once' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'overflow' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'pack' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'portable' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17] + 'redefine' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18] + 'regexp' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24] + 'signal' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25] + 'substr' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x15\x00\x00", # [27..38] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39] + 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41] + 'unopened' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45] + 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46] ); %DeadBits = ( - 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47] - 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27] - 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28] - 'chmod' => "\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0] - 'closed' => "\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5] - 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] - 'debugging' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20] - 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29] - 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30] - 'exec' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] - 'exiting' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] - 'glob' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'inplace' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21] - 'internal' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22] - 'io' => "\x00\xaa\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9] - 'malloc' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23] - 'misc' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] - 'newline' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] - 'numeric' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] - 'once' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'overflow' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13] - 'pack' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14] - 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31] - 'pipe' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'portable' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15] - 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32] - 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33] - 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34] - 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35] - 'recursion' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16] - 'redefine' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17] - 'regexp' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18] - 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36] - 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37] - 'severe' => "\x00\x00\x00\x00\x80\xaa\x00\x00\x00\x00\x00\x00", # [19..23] - 'signal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24] - 'substr' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25] - 'syntax' => "\x00\x00\x00\x00\x00\x00\xa0\xaa\xaa\x0a\x00\x00", # [26..37] - 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38] - 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39] - 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40] - 'unopened' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] - 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41] - 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44] - 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45] + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29] + 'chmod' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'debugging' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21] + 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'inplace' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22] + 'internal' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23] + 'io' => "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24] + 'misc' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'newline' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'numeric' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'once' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'overflow' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'pack' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'portable' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17] + 'redefine' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18] + 'regexp' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24] + 'signal' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25] + 'substr' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x2a\x00\x00", # [27..38] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39] + 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41] + 'unopened' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45] + 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46] ); -$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0"; +$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0"; +$LAST_BIT = 94 ; +$BYTES = 12 ; + +$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; sub bits { my $mask ; @@ -161,12 +230,12 @@ sub bits { if ($word eq 'FATAL') { $fatal = 1; } - else { - if ($catmask = $Bits{$word}) { - $mask |= $catmask ; - $mask |= $DeadBits{$word} if $fatal ; - } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; } + else + { croak("unknown warnings category '$word'")} } return $mask ; @@ -179,38 +248,70 @@ sub import { sub unimport { shift; - ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ; + my $mask = ${^WARNING_BITS} ; + if (vec($mask, $Offsets{'all'}, 1)) { + $mask = $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ; } sub enabled { - # If no parameters, check for any lexical warnings enabled - # in the users scope. + croak("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + local $Carp::CarpLevel = 1 ; + my $category ; + my $offset ; my $callers_bitmask = (caller(1))[9] ; - return ($callers_bitmask ne $NONE) if @_ == 0 ; - - # otherwise check for the category supplied. - my $category = shift ; - return 0 - unless $Bits{$category} ; return 0 unless defined $callers_bitmask ; - return 1 - if ($callers_bitmask & $Bits{$category}) ne $NONE ; - - return 0 ; + + + if (@_) { + # check the category supplied. + $category = shift ; + $offset = $Offsets{$category}; + croak("unknown warnings category '$category'") + unless defined $offset; + } + else { + $category = (caller(0))[0] ; + $offset = $Offsets{$category}; + croak("package '$category' not registered for warnings") + unless defined $offset ; + } + + return vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1) ; } + sub warn { - croak "Usage: warnings::warn('category', 'message')" - unless @_ == 2 ; - my $category = shift ; - my $message = shift ; + croak("Usage: warnings::warn([category,] 'message')") + unless @_ == 2 || @_ == 1 ; local $Carp::CarpLevel = 1 ; + my $category ; + my $offset ; my $callers_bitmask = (caller(1))[9] ; + + if (@_ == 2) { + $category = shift ; + $offset = $Offsets{$category}; + croak("unknown warnings category '$category'") + unless defined $offset ; + } + else { + $category = (caller(0))[0] ; + $offset = $Offsets{$category}; + croak("package '$category' not registered for warnings") + unless defined $offset ; + } + + my $message = shift ; croak($message) - if defined $callers_bitmask && - ($callers_bitmask & $DeadBits{$category}) ne $NONE ; + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; carp($message) ; } diff --git a/lib/warnings/register.pm b/lib/warnings/register.pm new file mode 100644 index 0000000000..da6be97952 --- /dev/null +++ b/lib/warnings/register.pm @@ -0,0 +1,30 @@ +package warnings::register ; + +require warnings ; + +sub mkMask +{ + my ($bit) = @_ ; + my $mask = "" ; + + vec($mask, $bit, 1) = 1 ; + return $mask ; +} + +sub import +{ + shift ; + my $package = (caller(0))[0] ; + if (! defined $warnings::Bits{$package}) { + $warnings::Bits{$package} = mkMask($warnings::LAST_BIT) ; + vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1 ; + $warnings::Offsets{$package} = $warnings::LAST_BIT ++ ; + foreach my $k (keys %warnings::Bits) { + vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0 ; + } + $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT); + vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1 ; + } +} + +1 ; |