diff options
Diffstat (limited to 'utils')
| -rw-r--r-- | utils/Makefile | 15 | ||||
| -rw-r--r-- | utils/h2ph.PL | 190 | ||||
| -rw-r--r-- | utils/perlbug.PL | 1115 | ||||
| -rw-r--r-- | utils/perlcc.PL | 935 | ||||
| -rw-r--r-- | utils/perldoc.PL | 67 |
5 files changed, 1641 insertions, 681 deletions
diff --git a/utils/Makefile b/utils/Makefile index 3c343c82b7..2df16d8060 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -1,13 +1,18 @@ PERL = ../miniperl +REALPERL = ../perl # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL -plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain +pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL +plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc +plextractexe = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe -all: $(plextract) +all: $(plextract) + +compile: all + $(REALPERL) -I../lib perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog; $(plextract): $(PERL) -I../lib $@.PL @@ -26,10 +31,12 @@ pl2pm: pl2pm.PL ../config.sh splain: splain.PL ../config.sh ../lib/diagnostics.pm +perlcc: perlcc.PL ../config.sh + clean: realclean: - rm -rf $(plextract) pstruct + rm -rf $(plextract) pstruct $(plextractexe) clobber: realclean diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 5c17e97ca0..2c685e0383 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -1,7 +1,7 @@ #!/usr/local/bin/perl use Config; -use File::Basename qw(&basename &dirname); +use File::Basename qw(basename dirname); # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -38,8 +38,7 @@ use Config; use File::Path qw(mkpath); use Getopt::Std; -getopts('d:rlh'); - +getopts('Dd:rlh'); my $Exit = 0; @@ -76,8 +75,7 @@ while (defined ($file = next_file())) { if ($file eq '-') { open(IN, "-"); open(OUT, ">-"); - } - else { + } else { ($outfile = $file) =~ s/\.h$/.ph/ || next; print "$file -> $outfile\n"; if ($file =~ m|^(.*)/|) { @@ -94,6 +92,7 @@ while (defined ($file = next_file())) { $_ .= <IN>; chop; } + print OUT "# $_\n" if $opt_D; if (s:/\*:\200:g) { s:\*/:\201:g; s/\200[^\201]*\201//g; # delete single line comments @@ -103,7 +102,7 @@ while (defined ($file = next_file())) { redo; } } - if (s/^#\s*//) { + if (s/^\s*#\s*//) { if (s/^define\s+(\w+)//) { $name = $1; $new = ''; @@ -122,86 +121,121 @@ while (defined ($file = next_file())) { } s/^\s+//; expr(); - $new =~ s/(["\\])/\\$1/g; + $new =~ s/(["\\])/\\$1/g; #"]); + $new = reindent($new); + $args = reindent($args); if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; + $new =~ s/(['\\])/\\$1/g; #']); if ($opt_h) { print OUT $t, - "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; $eval_index++; } else { print OUT $t, - "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; } - } - else { - print OUT "unless defined(\&$name) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n"; + } else { + print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n"; } %curargs = (); - } - else { + } else { s/^\s+//; expr(); $new = 1 if $new eq ''; + $new = reindent($new); + $args = reindent($args); if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; + $new =~ s/(['\\])/\\$1/g; #']); if ($opt_h) { print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; $eval_index++; } else { print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } - } - else { - print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n"; + } else { + print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n"; } } - } - elsif (/^include\s*<(.*)>/) { - ($incl = $1) =~ s/\.h$/.ph/; + } elsif (/^(include|import)\s*[<"](.*)[>"]/) { + ($incl = $2) =~ s/\.h$/.ph/; print OUT $t,"require '$incl';\n"; - } - elsif (/^ifdef\s+(\w+)/) { - print OUT $t,"if (defined &$1) {\n"; + } elsif(/^include_next\s*[<"](.*)[>"]/) { + ($incl = $1) =~ s/\.h$/.ph/; + # should've read up on #include_next properly before attempting + # to implement it... + # + #print OUT $t, "{\n"; + #$tab += 4; + #$t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + #print OUT $t, "my(\$INC) = shift(\@INC);\n"; + #print OUT $t, "require '$incl';\n"; + #print OUT $t, "unshift(\@INC, \$INC);}\n"; + #$tab -= 4; + #$t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + #print OUT $t, "}\n"; + # + # try this instead: + print OUT ($t, "my(\$i) = 0;\n"); + print OUT ($t, "if(exists(\$INC{$incl})) {\n"); $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^ifndef\s+(\w+)/) { - print OUT $t,"if (!defined &$1) {\n"; + print OUT ($t, "++\$i while (\$i <= \$#INC", + " and \$INC[\$i].'/$incl' ne \$INC{'$incl'});\n"); + print OUT ($t, "\$i = 0 if \$INC[\$i].'/$incl' ne", + " \$INC{'$incl'};\n"); + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT ($t, "}\n"); + print OUT ($t, + "eval(\"require '\" . ", + "(\$i ? \$INC[\$i].'/' : '') . \"\$incl';\");"); + # any better? require is smart enough not to try and include a + # file twice, i believe, so require-ing the same actual file + # should end up just being a null operation... + } elsif (/^ifdef\s+(\w+)/) { + print OUT $t,"if(defined(&$1)) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^if\s+//) { + } elsif (/^ifndef\s+(\w+)/) { + print OUT $t,"unless(defined(&$1)) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } elsif (s/^if\s+//) { $new = ''; $inif = 1; expr(); $inif = 0; - print OUT $t,"if ($new) {\n"; + print OUT $t,"if($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^elif\s+//) { + } elsif (s/^elif\s+//) { $new = ''; $inif = 1; expr(); $inif = 0; $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}elsif ($new) {\n"; + print OUT $t,"}\n elsif($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^else/) { + } elsif (/^else/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}else {\n"; + print OUT $t,"} else {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^endif/) { + } elsif (/^endif/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n"; + } elsif(/^undef\s+(\w+)/) { + print OUT $t, "undef(&$1) if defined(&$1);\n"; + } elsif(/^error\s+(.*)/) { + print OUT $t, "die(\"$1\");\n"; + } elsif(/^warning\s+(.*)/) { + print OUT $t, "warn(\"$1\");\n"; + } elsif(/^ident\s+(.*)/) { + print OUT $t, "# $1\n"; } } } @@ -210,10 +244,20 @@ while (defined ($file = next_file())) { exit $Exit; +sub reindent($) { + my($text) = shift; + $text =~ s/\n/\n /g; + $text =~ s/ /\t/g; + $text; +} + sub expr { + if(keys(%curargs)) { + my($joined_args) = join('|', keys(%curargs)); + } while ($_ ne '') { - s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator - s/^\&//; # hack for things that take the address of + s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator + s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of s/^(\s+)// && do {$new .= ' '; next;}; s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;}; s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;}; @@ -222,8 +266,7 @@ sub expr { s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { $new .= "ord('\$$1')"; - } - else { + } else { $new .= "ord('$1')"; } next; @@ -260,11 +303,22 @@ sub expr { } s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. }; - # struct/union member: - s/^([_A-Z]\w*((\.|->)[_A-Z]\w*)+)//i && do { + # struct/union member, including arrays: + s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { $id = $1; - $id =~ s/(\.|(->))([^\.-]*)/->\{$3\}/g; - $new .= ' ($' . $id . ')'; + $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g; + $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args); + while($id =~ /\[\s*([^\$\&\d\]]+)\]/) { + my($index) = $1; + $index =~ s/\s//g; + if(exists($curargs{$index})) { + $index = "\$$index"; + } else { + $index = "&$index"; + } + $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/; + } + $new .= " (\$$id)"; }; s/^([_a-zA-Z]\w*)// && do { $id = $1; @@ -272,41 +326,33 @@ sub expr { s/^\s+(\w+)//; $id .= ' ' . $1; $isatype{$id} = 1; - } - elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { + } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { while (s/^\s+(\w+)//) { $id .= ' ' . $1; } $isatype{$id} = 1; } if ($curargs{$id}) { - $new .= '$' . $id; - } - elsif ($id eq 'defined') { + $new .= "\$$id"; + $new .= '->' if /^[\[\{]/; + } elsif ($id eq 'defined') { $new .= 'defined'; - } - elsif (/^\(/) { + } elsif (/^\(/) { s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat $new .= " &$id"; - } - elsif ($isatype{$id}) { + } elsif ($isatype{$id}) { if ($new =~ /{\s*$/) { $new .= "'$id'"; - } - elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { + } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { $new =~ s/\(\s*$//; s/^[\s*]*\)//; - } - else { + } else { $new .= q(').$id.q('); } - } - else { + } else { if ($inif && $new !~ /defined\s*\($/) { $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; - } - elsif (/^\[/) { - $new .= ' $' . $id; - } - else { + } elsif (/^\[/) { + $new .= " \$$id"; + } else { $new .= ' &' . $id; } } @@ -334,7 +380,7 @@ sub next_file } else { print STDERR "Skipping directory `$file'\n"; } - } else { + } else { print STDERR "Skipping `$file': not a file or directory\n"; } } @@ -356,8 +402,11 @@ sub expand_glob # expand_glob() is going to be called until $ARGV[0] isn't a # directory; so push directories, and unshift everything else. - if (-d "$directory/$_") { push @ARGV, "$directory/$_" } - else { unshift @ARGV, "$directory/$_" } + if (-d "$directory/$_") { + push @ARGV, "$directory/$_"; + } else { + unshift @ARGV, "$directory/$_"; + } } closedir DIR; } @@ -382,7 +431,6 @@ sub link_if_possible unlink "$Dest_dir/$dirlink" or print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n"; } - if (eval 'symlink($target, "$Dest_dir/$dirlink")') { print "Linking $target -> $Dest_dir/$dirlink\n"; diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 724df6b449..68ff2901d5 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -17,7 +17,7 @@ chdir dirname($0); $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; -open OUT,">$file" or die "Can't create $file: $!"; +open OUT, ">$file" or die "Can't create $file: $!"; # extract patchlevel.h information @@ -27,7 +27,7 @@ my $patchlevel_date = (stat PATCH_LEVEL)[9]; while (<PATCH_LEVEL>) { last if $_ =~ /^\s*static\s+char.*?local_patches\[\]\s*=\s*{\s*$/; -}; +} my @patches; while (<PATCH_LEVEL>) { @@ -37,11 +37,9 @@ while (<PATCH_LEVEL>) { s/"?,?$//; s/(['\\])/\\$1/g; push @patches, $_ unless $_ eq 'NULL'; -}; -my $patch_desc = "'" . join("',\n\t'", @patches) . "'"; -my @patch_tags = map { my $p=$_; $p=~s/\s.*//; $p } @patches; -my $patch_tags = join " ", map { "+$_" } @patch_tags; -$patch_tags .= " " if $patch_tags; +} +my $patch_desc = "'" . join("',\n '", @patches) . "'"; +my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; close PATCH_LEVEL; @@ -65,7 +63,7 @@ my \$config_tag1 = '$] - $Config{cf_time}'; my \$patchlevel_date = $patchlevel_date; my \$patch_tags = '$patch_tags'; my \@patches = ( - $patch_desc + $patch_desc ); !GROK!THIS! @@ -75,21 +73,18 @@ print OUT <<'!NO!SUBS!'; use Config; use Getopt::Std; - -BEGIN { - eval "use Mail::Send;"; - $::HaveSend = ($@ eq ""); - eval "use Mail::Util;"; - $::HaveUtil = ($@ eq ""); -}; - - use strict; sub paraprint; +BEGIN { + eval "use Mail::Send;"; + $::HaveSend = ($@ eq ""); + eval "use Mail::Util;"; + $::HaveUtil = ($@ eq ""); +}; -my($Version) = "1.20"; +my $Version = "1.22"; # Changed in 1.06 to skip Mail::Send and Mail::Util if not available. # Changed in 1.07 to see more sendmail execs, and added pipe output. @@ -114,33 +109,32 @@ my($Version) = "1.20"; # add local patch information # warn on '-ok' if this is an old system; add '-okay' # Changed in 1.20 Added patchlevel.h reading and version/config checks +# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05 +# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10 # TODO: - Allow the user to re-name the file on mail failure, and -# make sure failure (transmission-wise) of Mail::Send is +# make sure failure (transmission-wise) of Mail::Send is # accounted for. # - Test -b option my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, - $subject, $from, $verbose, $ed, + $subject, $from, $verbose, $ed, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); my $config_tag2 = "$] - $Config{cf_time}"; Init(); -if($::opt_h) { Help(); exit; } - -if($::opt_d) { Dump(*STDOUT); exit; } - -if(!-t STDIN) { - paraprint <<EOF; -Please use perlbug interactively. If you want to +if ($::opt_h) { Help(); exit; } +if ($::opt_d) { Dump(*STDOUT); exit; } +if (!-t STDIN) { + paraprint <<EOF; +Please use perlbug interactively. If you want to include a file, you can use the -f switch. EOF - die "\n"; + die "\n"; } - -if(!-t STDOUT) { Dump(*STDOUT); exit; } +if (!-t STDOUT) { Dump(*STDOUT); exit; } Query(); Edit() unless $usefile; @@ -150,108 +144,114 @@ Send(); exit; sub Init { - - # -------- Setup -------- - - $Is_MSWin32 = $^O eq 'MSWin32'; - $Is_VMS = $^O eq 'VMS'; - - getopts("dhva:s:b:f:r:e:SCc:to:"); - - - # This comment is needed to notify metaconfig that we are - # using the $perladmin, $cf_by, and $cf_time definitions. - - - # -------- Configuration --------- - - # perlbug address - $perlbug = 'perlbug@perl.com'; - - - # Test address - $testaddress = 'perlbug-test@perl.com'; - - # Target address - $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); - - # Users address, used in message and in Reply-To header - $from = $::opt_r || ""; - - # Include verbose configuration information - $verbose = $::opt_v || 0; - - # Subject of bug-report message - $subject = $::opt_s || ""; - - # Send a file - $usefile = ($::opt_f || 0); - - # File to send as report - $file = $::opt_f || ""; - - # Body of report - $body = $::opt_b || ""; - - # Editor - $ed = ( $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} || - ($Is_VMS ? "edit/tpu" : $Is_MSWin32 ? "notepad" : "vi") - ); - - # OK - send "OK" report for build on this system - $ok = 0; - if ( $::opt_o ) { - if ( $::opt_o eq 'k' or $::opt_o eq 'kay' ) { - my $age = time - $patchlevel_date; - if ( $::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) { - my $date = localtime $patchlevel_date; - print <<"EOF"; -\"perlbug -ok\" does not report on Perl versions which are more than -60 days old. This Perl version was constructed on $date. -If you really want to report this, use \"perlbug -okay\". + # -------- Setup -------- + + $Is_MSWin32 = $^O eq 'MSWin32'; + $Is_VMS = $^O eq 'VMS'; + + getopts("dhva:s:b:f:r:e:SCc:to:n:"); + + # This comment is needed to notify metaconfig that we are + # using the $perladmin, $cf_by, and $cf_time definitions. + + # -------- Configuration --------- + + # perlbug address + $perlbug = 'perlbug@perl.com'; + + # Test address + $testaddress = 'perlbug-test@perl.com'; + + # Target address + $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); + + # Users address, used in message and in Reply-To header + $from = $::opt_r || ""; + + # Include verbose configuration information + $verbose = $::opt_v || 0; + + # Subject of bug-report message + $subject = $::opt_s || ""; + + # Send a file + $usefile = ($::opt_f || 0); + + # File to send as report + $file = $::opt_f || ""; + + # Body of report + $body = $::opt_b || ""; + + # Editor + $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} + || ($Is_VMS && "edit/tpu") + || ($Is_MSWin32 && "notepad") + || "vi"; + + # Not OK - provide build failure template by finessing OK report + if ($::opt_n) { + if (substr($::opt_n, 0, 2) eq 'ok' ) { + $::opt_o = substr($::opt_n, 1); + } else { + Help(); + exit(); + } + } + + # OK - send "OK" report for build on this system + $ok = 0; + if ($::opt_o) { + if ($::opt_o eq 'k' or $::opt_o eq 'kay') { + my $age = time - $patchlevel_date; + if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) { + my $date = localtime $patchlevel_date; + print <<"EOF"; +"perlbug -ok" and "perlbug -nok" do not report on Perl versions which +are more than 60 days old. This Perl version was constructed on +$date. If you really want to report this, use +"perlbug -okay" or "perlbug -nokay". EOF - exit(); - }; - # force these options - $::opt_S = 1; # don't prompt for send - $::opt_C = 1; # don't send a copy to the local admin - $::opt_s = 1; - $subject = "OK: perl $] ${patch_tags}on" - ." $::Config{'archname'} $::Config{'osvers'} $subject"; - $::opt_b = 1; - $body = "Perl reported to build OK on this system.\n"; - $ok = 1; - } - else { - Help(); exit(); } + # force these options + unless ($::opt_n) { + $::opt_S = 1; # don't prompt for send + $::opt_b = 1; # we have a body + $body = "Perl reported to build OK on this system.\n"; + } + $::opt_C = 1; # don't send a copy to the local admin + $::opt_s = 1; # we have a subject line + $subject = ($::opt_n ? 'Not ' : '') + . "OK: perl $] ${patch_tags}on" + ." $::Config{'archname'} $::Config{'osvers'} $subject"; + $ok = 1; + } else { + Help(); + exit(); } - - # Possible administrator addresses, in order of confidence - # (Note that cf_email is not mentioned to metaconfig, since - # we don't really want it. We'll just take it if we have to.) - # - # This has to be after the $ok stuff above because of the way - # that $::opt_C is forced. - $cc = ($::opt_C ? "" : ( - $::opt_c || $::Config{perladmin} || $::Config{cf_email} || $::Config{cf_by} - )); - - # My username - $me = ( $Is_MSWin32 - ? $ENV{'USERNAME'} - : ( $^O eq 'os2' - ? $ENV{'USER'} || $ENV{'LOGNAME'} - : eval { getpwuid($<) }) ); # May be missing - -} + } + # Possible administrator addresses, in order of confidence + # (Note that cf_email is not mentioned to metaconfig, since + # we don't really want it. We'll just take it if we have to.) + # + # This has to be after the $ok stuff above because of the way + # that $::opt_C is forced. + $cc = $::opt_C ? "" : ( + $::opt_c || $::Config{'perladmin'} + || $::Config{'cf_email'} || $::Config{'cf_by'} + ); + + # My username + $me = $Is_MSWin32 ? $ENV{'USERNAME'} + : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'} + : eval { getpwuid($<) }; # May be missing +} # sub Init sub Query { - - # Explain what perlbug is - if ( ! $ok ) { + # Explain what perlbug is + unless ($ok) { paraprint <<EOF; This program provides an easy way to create a message reporting a bug in perl, and e-mail it to $address. It is *NOT* intended for @@ -263,156 +263,121 @@ and any solutions to such problems, to the people who maintain perl. If you're just looking for help with perl, try posting to the Usenet newsgroup comp.lang.perl.misc. If you're looking for help with using perl with CGI, try posting to comp.infosystems.www.programming.cgi. - EOF } - - # Prompt for subject of message, if needed - if(! $subject) { - paraprint <<EOF; -First of all, please provide a subject for the -message. It should be a concise description of + # Prompt for subject of message, if needed + unless ($subject) { + paraprint <<EOF; +First of all, please provide a subject for the +message. It should be a concise description of the bug or problem. "perl bug" or "perl problem" is not a concise description. - EOF - print "Subject: "; - - $subject = <>; - chop $subject; - - my($err)=0; - while( $subject =~ /^\s*$/ ) { - print "\nPlease enter a subject: "; - $subject = <>; - chop $subject; - if($err++>5) { - die "Aborting.\n"; - } - } + print "Subject: "; + $subject = <>; + + my $err = 0; + while ($subject !~ /\S/) { + print "\nPlease enter a subject: "; + $subject = <>; + if ($err++ > 5) { + die "Aborting.\n"; + } } - - - # Prompt for return address, if needed - if( !$from) { - - # Try and guess return address - my($domain); - - if($::HaveUtil) { - $domain = Mail::Util::maildomain(); - } elsif ($Is_MSWin32) { - $domain = $ENV{'USERDOMAIN'}; + chop $subject; + } + + # Prompt for return address, if needed + unless ($from) { + # Try and guess return address + my $guess; + + $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || ''; + unless ($guess) { + my $domain; + if ($::HaveUtil) { + $domain = Mail::Util::maildomain(); + } elsif ($Is_MSWin32) { + $domain = $ENV{'USERDOMAIN'}; + } else { + require Sys::Hostname; + $domain = Sys::Hostname::hostname(); + } + if ($domain) { + if ($Is_VMS && !$::Config{'d_socket'}) { + $guess = "$domain\:\:$me"; } else { - require Sys::Hostname; - $domain = Sys::Hostname::hostname(); + $guess = "$me\@$domain" if $domain; } - - my($guess); - - if( !$domain) { - $guess = ""; - } elsif ($Is_VMS && !$::Config{'d_socket'}) { - $guess = "$domain\:\:$me"; - } else { - $guess = "$me\@$domain" if $domain; - $guess = "$me\@unknown.addresss" unless $domain; - } - - $guess = $ENV{'REPLYTO'} if defined($ENV{'REPLYTO'}); - $guess = $ENV{"REPLY-TO"} if defined($ENV{'REPLY-TO'}); - - if( $guess ) { - if ( ! $ok ) { - paraprint <<EOF; - + } + } + if ($guess) { + unless ($ok) { + paraprint <<EOF; Your e-mail address will be useful if you need to be contacted. If the default shown is not your full internet e-mail address, please correct it. - EOF - } - } else { - paraprint <<EOF; - -So that you may be contacted if necessary, please enter + } + } else { + paraprint <<EOF; +So that you may be contacted if necessary, please enter your full internet e-mail address here. - EOF - } - - if ( $ok && $guess ne '' ) { - # use it - $from = $guess; - } - else { - # verify it - print "Your address [$guess]: "; - - $from = <>; - chop $from; - - if($from eq "") { $from = $guess } - } - } - - #if( $from =~ /^(.*)\@(.*)$/ ) { - # $mailname = $1; - # $maildomain = $2; - #} - - if( $from eq $cc or $me eq $cc ) { - # Try not to copy ourselves - $cc = "yourself"; - } - - # Prompt for administrator address, unless an override was given - if( !$::opt_C and !$::opt_c ) { - paraprint <<EOF; + if ($ok && $guess) { + # use it + $from = $guess; + } else { + # verify it + print "Your address [$guess]: "; + $from = <>; + chop $from; + $from = $guess if $from eq ''; + } + } + if ($from eq $cc or $me eq $cc) { + # Try not to copy ourselves + $cc = "yourself"; + } + # Prompt for administrator address, unless an override was given + if( !$::opt_C and !$::opt_c ) { + paraprint <<EOF; A copy of this report can be sent to your local -perl administrator. If the address is wrong, please +perl administrator. If the address is wrong, please correct it, or enter 'none' or 'yourself' to not send a copy. - EOF + print "Local perl administrator [$cc]: "; + my $entry = scalar <>; + chop $entry; - print "Local perl administrator [$cc]: "; - - my($entry) = scalar(<>); - chop $entry; - - if($entry ne "") { - $cc = $entry; - if($me eq $cc) { $cc = "" } - } - + if ($entry ne "") { + $cc = $entry; + $cc = '' if $me eq $cc; } + } - if($cc =~ /^(none|yourself|me|myself|ourselves)$/i) { $cc = "" } - - $andcc = " and $cc" if $cc; + $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i; + $andcc = " and $cc" if $cc; + # Prompt for editor, if no override is given editor: - - # Prompt for editor, if no override is given - if(! $::opt_e and ! $::opt_f and ! $::opt_b) { - paraprint <<EOF; - - + unless ($::opt_e || $::opt_f || $::opt_b) { + paraprint <<EOF; Now you need to supply the bug report. Try to make -the report concise but descriptive. Include any +the report concise but descriptive. Include any relevant detail. If you are reporting something that does not work as you think it should, please -try to include example of both the actual +try to include example of both the actual result, and what you expected. Some information about your local -perl configuration will automatically be included +perl configuration will automatically be included at the end of the report. If you are using any unusual version of perl, please try and confirm exactly which versions are relevant. @@ -424,96 +389,71 @@ the name of the editor you would like to use. If you would like to use a prepared file, type "file", and you will be asked for the filename. - EOF - - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - $usefile = 0; - if($entry eq "file") { - $usefile = 1; - } elsif($entry ne "") { - $ed = $entry; - } + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + + $usefile = 0; + if ($entry eq "file") { + $usefile = 1; + } elsif ($entry ne "") { + $ed = $entry; } + } + # Generate scratch file to edit report in + $filename = filename(); - # Generate scratch file to edit report in - - { - my($dir) = ($Is_VMS ? 'sys$scratch:' : - (($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} : '/tmp/')); - $filename = "bugrep0$$"; - $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; - $filename++ while -e "$dir$filename"; - $filename = "$dir$filename"; - } - - - # Prompt for file to read report from, if needed - - if( $usefile and ! $file) { + # Prompt for file to read report from, if needed + if ($usefile and !$file) { filename: - paraprint <<EOF; - + paraprint <<EOF; What is the name of the file that contains your report? - EOF + print "Filename: "; + my $entry = scalar <>; + chop $entry; - print "Filename: "; - - my($entry) = scalar(<>); - chop($entry); - - if($entry eq "") { - paraprint <<EOF; - -No filename? I'll let you go back and choose an editor again. - + if ($entry eq "") { + paraprint <<EOF; +No filename? I'll let you go back and choose an editor again. EOF - goto editor; - } - - if(!-f $entry or !-r $entry) { - paraprint <<EOF; - + goto editor; + } + + unless (-f $entry and -r $entry) { + paraprint <<EOF; I'm sorry, but I can't read from `$entry'. Maybe you mistyped the name of the file? If you don't want to send a file, just enter a blank line and you can get back to the editor selection. - EOF - goto filename; - } - $file = $entry; - + goto filename; } + $file = $entry; + } + # Generate report + open(REP,">$filename"); + my $reptype = $ok ? "build failure" : "bug"; - # Generate report - - open(REP,">$filename"); - - my $reptype = $ok ? "success" : "bug"; - - print REP <<EOF; + print REP <<EOF; This is a $reptype report for perl from $from, generated with the help of perlbug $Version running under perl $]. EOF - if($body) { - print REP $body; - } elsif($usefile) { - open(F,"<$file") or die "Unable to read report file from `$file': $!\n"; - while(<F>) { - print REP $_ - } - close(F); - } else { - print REP <<EOF; + if ($body) { + print REP $body; + } elsif ($usefile) { + open(F, "<$file") + or die "Unable to read report file from `$file': $!\n"; + while (<F>) { + print REP $_ + } + close(F); + } else { + print REP <<EOF; ----------------------------------------------------------------- [Please enter your report here] @@ -523,164 +463,138 @@ EOF [Please do not change anything below this line] ----------------------------------------------------------------- EOF - } - - Dump(*REP); - close(REP); - - # read in the report template once so that - # we can track whether the user does any editing. - # yes, *all* whitespace is ignored. - open(REP, "<$filename"); - while (<REP>) { - s/\s+//g; - $REP{$_}++; - } - close(REP); - -} + } + Dump(*REP); + close(REP); + + # read in the report template once so that + # we can track whether the user does any editing. + # yes, *all* whitespace is ignored. + open(REP, "<$filename"); + while (<REP>) { + s/\s+//g; + $REP{$_}++; + } + close(REP); +} # sub Query sub Dump { - local(*OUT) = @_; - - print REP "\n---\n"; + local(*OUT) = @_; - print REP "This perlbug was built using Perl $config_tag1\n", - "It is being executed now by Perl $config_tag2.\n\n" - if $config_tag2 ne $config_tag1; + print REP "\n---\n"; + print REP "This perlbug was built using Perl $config_tag1\n", + "It is being executed now by Perl $config_tag2.\n\n" + if $config_tag2 ne $config_tag1; - print OUT <<EOF; + print OUT <<EOF; Site configuration information for perl $]: EOF + if ($::Config{cf_by} and $::Config{cf_time}) { + print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n"; + } + print OUT Config::myconfig; - if( $::Config{cf_by} and $::Config{cf_time}) { - print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n"; - } - - print OUT Config::myconfig; - - if (@patches) { - print OUT join "\n\t", "Locally applied patches:", @patches; - print OUT "\n"; - }; + if (@patches) { + print OUT join "\n ", "Locally applied patches:", @patches; + print OUT "\n"; + }; - print OUT <<EOF; + print OUT <<EOF; --- \@INC for perl $]: EOF - for my $i (@INC) { - print OUT "\t$i\n"; - } + for my $i (@INC) { + print OUT " $i\n"; + } - print OUT <<EOF; + print OUT <<EOF; --- Environment for perl $]: EOF - for my $env (sort - (qw(PATH LD_LIBRARY_PATH - LANG PERL_BADLANG - SHELL HOME LOGDIR), - grep { /^(?:PERL|LC_)/ } keys %ENV)) { - print OUT " $env", - exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', - "\n"; - } - if($verbose) { - print OUT "\nComplete configuration data for perl $]:\n\n"; - my($value); - foreach (sort keys %::Config) { - $value = $::Config{$_}; - $value =~ s/'/\\'/g; - print OUT "$_='$value'\n"; - } + for my $env (sort + (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR), + grep /^(?:PERL|LC_)/, keys %ENV) + ) { + print OUT " $env", + exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', + "\n"; + } + if ($verbose) { + print OUT "\nComplete configuration data for perl $]:\n\n"; + my $value; + foreach (sort keys %::Config) { + $value = $::Config{$_}; + $value =~ s/'/\\'/g; + print OUT "$_='$value'\n"; } -} + } +} # sub Dump sub Edit { - # Edit the report - - if($usefile) { - $usefile = 0; - paraprint <<EOF; - + # Edit the report + if ($usefile || $body) { + paraprint <<EOF; Please make sure that the name of the editor you want to use is correct. - EOF - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - if($entry ne "") { - $ed = $entry; - } - } - -tryagain: - if(!$usefile and !$body) { - my $sts = system("$ed $filename"); - if($sts) { - #print "\nUnable to run editor!\n"; - paraprint <<EOF; + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + $ed = $entry unless $entry eq ''; + } +tryagain: + my $sts = system("$ed $filename"); + if ($sts) { + paraprint <<EOF; The editor you chose (`$ed') could apparently not be run! Did you mistype the name of your editor? If so, please -correct it here, otherwise just press Enter. - +correct it here, otherwise just press Enter. EOF - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - if($entry ne "") { - $ed = $entry; - goto tryagain; - } else { - - paraprint <<EOF; + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + if ($entry ne "") { + $ed = $entry; + goto tryagain; + } else { + paraprint <<EOF; You may want to save your report to a file, so you can edit and mail it yourself. EOF - } - } - } - - return if $ok; - # Check that we have a report that has some, eh, report in it. - - my $unseen = 0; - - open(REP, "<$filename"); - # a strange way to check whether any significant editing - # have been done: check whether any new non-empty lines - # have been added. Yes, the below code ignores *any* space - # in *any* line. - while (<REP>) { - s/\s+//g; - $unseen++ if ($_ ne '' and not exists $REP{$_}); } + } - while ($unseen == 0) { - paraprint <<EOF; + return if ($ok and not $::opt_n) || $body; + # Check that we have a report that has some, eh, report in it. + my $unseen = 0; + + open(REP, "<$filename"); + # a strange way to check whether any significant editing + # have been done: check whether any new non-empty lines + # have been added. Yes, the below code ignores *any* space + # in *any* line. + while (<REP>) { + s/\s+//g; + $unseen++ if $_ ne '' and not exists $REP{$_}; + } + while ($unseen == 0) { + paraprint <<EOF; I am sorry but it looks like you did not report anything. - EOF - print "Action (Retry Edit/Cancel) "; - my ($action) = scalar(<>); - if ($action =~ /^[re]/i) { # <R>etry <E>dit - goto tryagain; - } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit - Cancel(); - } - } - -} + print "Action (Retry Edit/Cancel) "; + my ($action) = scalar(<>); + if ($action =~ /^[re]/i) { # <R>etry <E>dit + goto tryagain; + } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit + Cancel(); + } + } +} # sub Edit sub Cancel { 1 while unlink($filename); # remove all versions under VMS @@ -689,227 +603,211 @@ sub Cancel { } sub NowWhat { - - # Report is done, prompt for further action - if( !$::opt_S ) { - while(1) { - - paraprint <<EOF; - - -Now that you have completed your report, would you like to send -the message to $address$andcc, display the message on + # Report is done, prompt for further action + if( !$::opt_S ) { + while(1) { + paraprint <<EOF; +Now that you have completed your report, would you like to send +the message to $address$andcc, display the message on the screen, re-edit it, or cancel without sending anything? You may also save the message as a file to mail at another time. - EOF - - print "Action (Send/Display/Edit/Cancel/Save to File): "; - my($action) = scalar(<>); - chop $action; - - if( $action =~ /^(f|sa)/i ) { # <F>ile/<Sa>ve - print "\n\nName of file to save message in [perlbug.rep]: "; - my($file) = scalar(<>); - chop $file; - if($file eq "") { $file = "perlbug.rep" } - - open(FILE,">$file"); - open(REP,"<$filename"); - print FILE "To: $address\nSubject: $subject\n"; - print FILE "Cc: $cc\n" if $cc; - print FILE "Reply-To: $from\n" if $from; - print FILE "\n"; - while(<REP>) { print FILE } - close(REP); - close(FILE); - - print "\nMessage saved in `$file'.\n"; - exit; - - } elsif( $action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow - # Display the message - open(REP,"<$filename"); - while(<REP>) { print $_ } - close(REP); - } elsif( $action =~ /^se/i ) { # <S>end - # Send the message - print "\ -Are you certain you want to send this message? -Please type \"yes\" if you are: "; - my($reply) = scalar(<STDIN>); - chop($reply); - if( $reply eq "yes" ) { - last; - } else { - paraprint <<EOF; - + print "Action (Send/Display/Edit/Cancel/Save to File): "; + my $action = scalar <>; + chop $action; + + if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve + print "\n\nName of file to save message in [perlbug.rep]: "; + my $file = scalar <>; + chop $file; + $file = "perlbug.rep" if $file eq ""; + + open(FILE, ">$file"); + open(REP, "<$filename"); + print FILE "To: $address\nSubject: $subject\n"; + print FILE "Cc: $cc\n" if $cc; + print FILE "Reply-To: $from\n" if $from; + print FILE "\n"; + while (<REP>) { print FILE } + close(REP); + close(FILE); + + print "\nMessage saved in `$file'.\n"; + exit; + } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow + # Display the message + open(REP, "<$filename"); + while (<REP>) { print $_ } + close(REP); + } elsif ($action =~ /^se/i) { # <S>end + # Send the message + print "Are you certain you want to send this message?\n" + . 'Please type "yes" if you are: '; + my $reply = scalar <STDIN>; + chop $reply; + if ($reply eq "yes") { + last; + } else { + paraprint <<EOF; That wasn't a clear "yes", so I won't send your message. If you are sure your message should be sent, type in "yes" (without the quotes) at the confirmation prompt. - EOF - - } - } elsif( $action =~ /^[er]/i ) { # <E>dit, <R>e-edit - # edit the message - Edit(); - #system("$ed $filename"); - } elsif( $action =~ /^[qc]/i ) { # <C>ancel, <Q>uit - Cancel(); - } elsif( $action =~ /^s/ ) { - paraprint <<EOF; - + } + } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit + # edit the message + Edit(); + } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit + Cancel(); + } elsif ($action =~ /^s/) { + paraprint <<EOF; I'm sorry, but I didn't understand that. Please type "send" or "save". EOF - } - - } + } } -} - + } +} # sub NowWhat sub Send { + # Message has been accepted for transmission -- Send the message + if ($::HaveSend) { + $msg = new Mail::Send Subject => $subject, To => $address; + $msg->cc($cc) if $cc; + $msg->add("Reply-To",$from) if $from; + + $fh = $msg->open; + open(REP, "<$filename"); + while (<REP>) { print $fh $_ } + close(REP); + $fh->close; + + print "\nMessage sent.\n"; + } elsif ($Is_VMS) { + if ( ($address =~ /@/ and $address !~ /^\w+%"/) or + ($cc =~ /@/ and $cc !~ /^\w+%"/) ) { + my $prefix; + foreach (qw[ IN MX SMTP UCX PONY WINS ], '') { + $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"}; + } + $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/; + $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/; + } + $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g; + my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]); + if ($sts) { + die <<EOF; +Can't spawn off mail + (leaving bug report in $filename): $sts +EOF + } + } else { + my $sendmail = ""; + for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) { + $sendmail = $_, last if -e $_; + } + if ($^O eq 'os2' and $sendmail eq "") { + my $path = $ENV{PATH}; + $path =~ s:\\:/: ; + my @path = split /$Config{'path_sep'}/, $path; + for (@path) { + $sendmail = "$_/sendmail", last if -e "$_/sendmail"; + $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe"; + } + } - # Message has been accepted for transmission -- Send the message - - if($::HaveSend) { - - $msg = new Mail::Send Subject => $subject, To => $address; - - $msg->cc($cc) if $cc; - $msg->add("Reply-To",$from) if $from; - - $fh = $msg->open; - - open(REP,"<$filename"); - while(<REP>) { print $fh $_ } - close(REP); - - $fh->close; - - print "\nMessage sent.\n"; - } else { - if ($Is_VMS) { - if ( ($address =~ /@/ and $address !~ /^\w+%"/) or - ($cc =~ /@/ and $cc !~ /^\w+%"/) ){ - my($prefix); - foreach (qw[ IN MX SMTP UCX PONY WINS ],'') { - $prefix = "$_%",last if $ENV{"MAIL\$PROTOCOL_$_"}; - } - $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/; - $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/; - } - $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g; - my($sts) = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]); - if ($sts) { die "Can't spawn off mail\n\t(leaving bug report in $filename): $sts\n;" } - } else { - my($sendmail) = ""; - - foreach (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) - { - $sendmail = $_, last if -e $_; - } - - if ($^O eq 'os2' and $sendmail eq "") { - my $path = $ENV{PATH}; - $path =~ s:\\:/: ; - my @path = split /$Config{path_sep}/, $path; - for (@path) { - $sendmail = "$_/sendmail", last - if -e "$_/sendmail"; - $sendmail = "$_/sendmail.exe", last - if -e "$_/sendmail.exe"; - } - } - - paraprint(<<"EOF"), die "\n" if $sendmail eq ""; - + paraprint(<<"EOF"), die "\n" if $sendmail eq ""; I am terribly sorry, but I cannot find sendmail, or a close equivalent, and the perl package Mail::Send has not been installed, so I can't send your bug report. We apologize for the inconvenience. So you may attempt to find some way of sending your message, it has been left in the file `$filename'. - EOF - - open(SENDMAIL,"|$sendmail -t") || die "'|$sendmail -t' failed: $|"; - print SENDMAIL "To: $address\n"; - print SENDMAIL "Subject: $subject\n"; - print SENDMAIL "Cc: $cc\n" if $cc; - print SENDMAIL "Reply-To: $from\n" if $from; - print SENDMAIL "\n\n"; - open(REP,"<$filename"); - while(<REP>) { print SENDMAIL $_ } - close(REP); - - if (close(SENDMAIL)) { - print "\nMessage sent.\n"; - } else { - warn "\nSendmail returned status '",$?>>8,"'\n"; - } - } - - } - - 1 while unlink($filename); # remove all versions under VMS + open(SENDMAIL, "|$sendmail -t") || die "'|$sendmail -t' failed: $!"; + print SENDMAIL "To: $address\n"; + print SENDMAIL "Subject: $subject\n"; + print SENDMAIL "Cc: $cc\n" if $cc; + print SENDMAIL "Reply-To: $from\n" if $from; + print SENDMAIL "\n\n"; + open(REP, "<$filename"); + while (<REP>) { print SENDMAIL $_ } + close(REP); -} + if (close(SENDMAIL)) { + print "\nMessage sent.\n"; + } else { + warn "\nSendmail returned status '", $? >> 8, "'\n"; + } + } + 1 while unlink($filename); # remove all versions under VMS +} # sub Send sub Help { - print <<EOF; + print <<EOF; -A program to help generate bug reports about perl5, and mail them. +A program to help generate bug reports about perl5, and mail them. It is designed to be used interactively. Normally no arguments will be needed. - + Usage: $0 [-v] [-a address] [-s subject] [-b body | -f file ] [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h] - +$0 [-v] [-r returnaddress] [-ok | -okay | -nok | -nokay] + Simplest usage: run "$0", and follow the prompts. Options: -v Include Verbose configuration data in the report - -f File containing the body of the report. Use this to + -f File containing the body of the report. Use this to quickly send a prepared message. -S Send without asking for confirmation. -a Address to send the report to. Defaults to `$address'. -c Address to send copy of report to. Defaults to `$cc'. -C Don't send copy to administrator. - -s Subject to include with the message. You will be prompted + -s Subject to include with the message. You will be prompted if you don't supply one on the command line. -b Body of the report. If not included on the command line, or in a file with -f, you will get a chance to edit the message. -r Your return address. The program will ask you to confirm this if you don't give it here. - -e Editor to use. + -e Editor to use. -t Test mode. The target address defaults to `$testaddress'. - -d Data mode (the default if you redirect or pipe output.) + -d Data mode (the default if you redirect or pipe output.) This prints out your configuration data, without mailing anything. You can use this with -v to get more complete data. -ok Report successful build on this system to perl porters - (use alone or with -v). Only use -ok if *everything* was ok. - If there were *any* problems at all then don't use -ok. + (use alone or with -v). Only use -ok if *everything* was ok: + if there were *any* problems at all, use -nok. -okay As -ok but allow report from old builds. - -h Print this help message. - + -nok Report unsuccessful build on this system to perl porters + (use alone or with -v). You must describe what went wrong + in the body of the report which you will be asked to edit. + -nokay As -nok but allow report from old builds. + -h Print this help message. + EOF } +sub filename { + my $dir = $Is_VMS ? 'sys$scratch:' + : ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} + : '/tmp/'; + $filename = "bugrep0$$"; + $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; + $filename++ while -e "$dir$filename"; + $filename = "$dir$filename"; +} + sub paraprint { my @paragraphs = split /\n{2,}/, "@_"; print "\n\n"; for (@paragraphs) { # implicit local $_ - s/(\S)\s*\n/$1 /g; - write; - print "\n"; + s/(\S)\s*\n/$1 /g; + write; + print "\n"; } - } - format STDOUT = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ @@ -929,12 +827,13 @@ S<[ B<-b> I<body> | B<-f> I<file> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]> S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]> -B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-ok> | B<okay> ]> +B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> +S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> =head1 DESCRIPTION A program to help generate bug reports about perl or the modules that -come with it, and mail them. +come with it, and mail them. If you have found a bug with a non-standard port (one that was not part of the I<standard distribution>), a binary distribution, or a @@ -1073,7 +972,7 @@ with B<-v> to get more complete data. =item B<-e> -Editor to use. +Editor to use. =item B<-f> @@ -1097,6 +996,21 @@ system is less than 60 days old. As B<-ok> except it will report on older systems. +=item B<-nok> + +Report unsuccessful build on this system. Forces B<-C>. Forces and +supplies a value for B<-s>, then requires you to edit the report +and say what went wrong. Alternatively, a prepared report may be +supplied using B<-f>. Only prompts for a return address if it +cannot guess it (for use with B<make>). Honors return address +specified with B<-r>. You can use this with B<-v> to get more +complete data. Only makes a report if this system is less than 60 +days old. + +=item B<-nokay> + +As B<-nok> except it will report on older systems. + =item B<-r> Your return address. The program will ask you to confirm its default @@ -1126,8 +1040,9 @@ Include verbose configuration data in the report. Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>), -Charles F. Randall (E<lt>cfr@pobox.comE<gt>) and -Mike Guy (E<lt>mjtg@cam.a.ukE<gt>). +Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy +(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>) +and Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>). =head1 SEE ALSO diff --git a/utils/perlcc.PL b/utils/perlcc.PL new file mode 100644 index 0000000000..af7488f484 --- /dev/null +++ b/utils/perlcc.PL @@ -0,0 +1,935 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. +# Wanted: $archlibexp + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +use Config; +use strict; +use FileHandle; +use File::Basename qw(&basename &dirname); + +use Getopt::Long; + +$Getopt::Long::bundling_override = 1; +$Getopt::Long::passthrough = 0; +$Getopt::Long::ignore_case = 0; + +my $options = {}; +my $_fh; + +main(); + +sub main +{ + + GetOptions + ( + $options, "L:s", + "I:s", + "C:s", + "o:s", + "e:s", + "regex:s", + "verbose:s", + "log:s", + "argv:s", + "gen", + "sav", + "run", + "prog", + "mod" + ); + + + my $key; + + local($") = "|"; + + _usage() if (!_checkopts()); + push(@ARGV, _maketempfile()) if ($options->{'e'}); + + _usage() if (!@ARGV); + + my $file; + foreach $file (@ARGV) + { + _print(" +-------------------------------------------------------------------------------- +Compiling $file: +-------------------------------------------------------------------------------- +", 36 ); + _doit($file); + } +} + +sub _doit +{ + my ($file) = @_; + + my ($program_ext, $module_ext) = _getRegexps(); + my ($obj, $objfile, $so, $type); + + if ( + (($file =~ m"@$program_ext") && ($file !~ m"@$module_ext")) + || (defined($options->{'prog'}) || defined($options->{'run'})) + ) + { + $objfile = ($options->{'C'}) ? $options->{'C'} : "$file.c"; + $type = 'program'; + + $obj = ($options->{'o'})? $options->{'o'} : + _getExecutable( $file,$program_ext); + + return() if (!$obj); + + } + elsif (($file =~ m"@$module_ext") || ($options->{'mod'})) + { + die "Shared objects are not supported on Win32 yet!!!!\n" + if ($Config{'osname'} eq 'MSWin32'); + + $obj = ($options->{'o'})? $options->{'o'} : + _getExecutable($file, $module_ext); + $so = "$obj.so"; + $type = 'sharedlib'; + return() if (!$obj); + } + else + { + _error("noextension", $file, $program_ext, $module_ext); + return(); + } + + if ($type eq 'program') + { + _print("Making C($objfile) for $file!\n", 36 ); + + my $errcode = _createCode($objfile, $file); + (_print( "ERROR: In generating code for $file!\n", -1), return()) + if ($errcode); + + _print("Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'}); + my $errcode = _compileCode($file, $objfile, $obj) + if (!$options->{'gen'}); + + if ($errcode) + { + _print( "ERROR: In compiling code for $objfile !\n", -1); + my $ofile = File::Basename::basename($objfile); + $ofile =~ s"\.c$"\.o"s; + + _removeCode("$ofile"); + return() + } + + _runCode($obj) if ($options->{'run'}); + + _removeCode($objfile) if (!$options->{'sav'} || + ($options->{'e'} && !$options->{'C'})); + + _removeCode($file) if ($options->{'e'}); + + _removeCode($obj) if (($options->{'e'} && + ((!$options->{'sav'}) || !$options->{'o'})) || + ($options->{'run'} && (!$options->{'sav'}))); + } + else + { + _print( "Making C($objfile) for $file!\n", 36 ); + my $errcode = _createCode($objfile, $file, $obj); + (_print( "ERROR: In generating code for $file!\n", -1), return()) + if ($errcode); + + _print( "Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'}); + + my $errorcode = + _compileCode($file, $objfile, $obj, $so ) if (!$options->{'gen'}); + + (_print( "ERROR: In compiling code for $objfile!\n", -1), return()) + if ($errcode); + } +} + +sub _getExecutable +{ + my ($sourceprog, $ext) = @_; + my ($obj); + + if (defined($options->{'regex'})) + { + eval("(\$obj = \$sourceprog) =~ $options->{'regex'}"); + return(0) if (_error('badeval', $@)); + return(0) if (_error('equal', $obj, $sourceprog)); + } + elsif (defined ($options->{'ext'})) + { + ($obj = $sourceprog) =~ s"@$ext"$options->{ext}"g; + return(0) if (_error('equal', $obj, $sourceprog)); + } + elsif (defined ($options->{'run'})) + { + $obj = "perlc$$"; + } + else + { + ($obj = $sourceprog) =~ s"@$ext""g; + return(0) if (_error('equal', $obj, $sourceprog)); + } + return($obj); +} + +sub _createCode +{ + my ( $generated_cfile, $file, $final_output ) = @_; + my $return; + + local($") = " -I"; + + if (@_ == 2) # compiling a program + { + _print( "$^X -I@INC -MO=CC,-o$generated_cfile $file\n", 36); + $return = _run("$ -I@INC -MO=CC,-o$generated_cfile $file", 9); + $return; + } + else # compiling a shared object + { + _print( + "$ -I@INC -MO=CC,-m$final_output,-o$generated_cfile $file\n", 36); + $return = + _run("$ -I@INC -MO=CC,-m$final_output,-o$generated_cfile $file", 9); + $return; + } +} + +sub _compileCode +{ + my ($sourceprog, $generated_cfile, $output_executable, $shared_object) = @_; + my @return; + + if (@_ == 3) # just compiling a program + { + $return[0] = + _ccharness($sourceprog, "-o", $output_executable, $generated_cfile); + $return[0]; + } + else + { + my $object_file = $generated_cfile; + $object_file =~ s"\.c$"\.o"; + + $return[0] = _ccharness($sourceprog, "-c", $generated_cfile); + $return[1] = _ccharness + ( + $sourceprog, "-shared","-o", + $shared_object, $object_file + ); + return(1) if (grep ($_, @return)); + return(0); + } +} + +sub _runCode +{ + my ($executable) = @_; + _print("$executable $options->{'argv'}\n", 36); + _run("$executable $options->{'argv'}", -1 ); +} + +sub _removeCode +{ + my ($file) = @_; + unlink($file) if (-e $file); +} + +sub _ccharness +{ + my (@args) = @_; + local($") = " "; + + my $sourceprog = shift(@args); + my ($libdir, $incdir); + + if (-d "$Config{installarchlib}/CORE") + { + $libdir = "-L$Config{installarchlib}/CORE"; + $incdir = "-I$Config{installarchlib}/CORE"; + } + else + { + $libdir = "-L.."; + $incdir = "-I.."; + } + + $libdir .= " -L$options->{L}" if (defined($options->{L})); + $incdir .= " -I$options->{L}" if (defined($options->{L})); + + my $linkargs; + + if (!grep(/^-[cS]$/, @ARGV)) + { + $linkargs = sprintf("%s $libdir -lperl %s",@Config{qw(ldflags libs)}); + } + + my @sharedobjects = _getSharedObjects($sourceprog); + + my $cccmd = + "$Config{cc} $Config{ccflags} $incdir @sharedobjects @args $linkargs"; + + + _print ("$cccmd\n", 36); + _run("$cccmd", 18 ); +} + +sub _getSharedObjects +{ + my ($sourceprog) = @_; + my ($tmpfile, $incfile); + my (@return); + local($") = " -I"; + + if ($Config{'osname'} eq 'MSWin32') + { + # _addstuff; + } + else + { + my ($tmpprog); + ($tmpprog = $sourceprog) =~ s"(.*)[\/\\](.*)"$2"; + $tmpfile = "/tmp/$tmpprog.tst"; + $incfile = "/tmp/$tmpprog.val"; + } + + my $fd = new FileHandle("> $tmpfile") || die "Couldn't open $tmpfile!\n"; + my $fd2 = + new FileHandle("$sourceprog") || die "Couldn't open $sourceprog!\n"; + + my $perl = <$fd2>; # strip off header; + + print $fd +<<"EOF"; + use FileHandle; + my \$fh3 = new FileHandle("> $incfile") + || die "Couldn't open $incfile\\n"; + + my \$key; + foreach \$key (keys(\%INC)) { print \$fh3 "\$key:\$INC{\$key}\\n"; } + close(\$fh3); + exit(); +EOF + + print $fd ( <$fd2> ); + close($fd); + + _print("$ -I@INC $tmpfile\n", 36); + _run("$ -I@INC $tmpfile", 9 ); + + my $fd = new FileHandle ("$incfile"); + my @lines = <$fd>; + + unlink($tmpfile); + unlink($incfile); + + my $line; + my $autolib; + + foreach $line (@lines) + { + chomp($line); + my ($modname, $modpath) = split(':', $line); + my ($dir, $file) = ($modpath=~ m"(.*)[\\/]($modname)"); + + if ($autolib = _lookforAuto($dir, $file)) + { + push(@return, $autolib); + } + } + + return(@return); +} + +sub _maketempfile +{ + my $return; + +# if ($Config{'osname'} eq 'MSWin32') +# { $return = "C:\\TEMP\\comp$$.p"; } +# else +# { $return = "/tmp/comp$$.p"; } + + $return = "comp$$.p"; + + my $fd = new FileHandle( "> $return") || die "Couldn't open $return!\n"; + print $fd $options->{'e'}; + close($fd); + + return($return); +} + + +sub _lookforAuto +{ + my ($dir, $file) = @_; + + my $relshared; + my $return; + + ($relshared = $file) =~ s"(.*)\.pm"$1"; + + my ($tmp, $modname) = ($relshared =~ m"(?:(.*)[\\/]){0,1}(.*)"s); + + $relshared .= + ($Config{'osname'} eq 'MSWin32')? "\\$modname.dll" : "/$modname.so"; + + + + if (-e ($return = "$Config{'installarchlib'}/auto/$relshared") ) + { + return($return); + } + elsif (-e ($return = "$Config{'installsitearch'}/auto/$relshared")) + { + return($return); + } + elsif (-e ($return = "$dir/arch/auto/$relshared")) + { + return($return); + } + else + { + return(undef); + } +} + +sub _getRegexps # make the appropriate regexps for making executables, +{ # shared libs + + my ($program_ext, $module_ext) = ([],[]); + + + @$program_ext = ($ENV{PERL_SCRIPT_EXT})? split(':', $ENV{PERL_SCRIPT_EXT}) : + ('.p$', '.pl$', '.bat$'); + + + @$module_ext = ($ENV{PERL_MODULE_EXT})? split(':', $ENV{PERL_MODULE_EXT}) : + ('.pm$'); + + + _mungeRegexp( $program_ext ); + _mungeRegexp( $module_ext ); + + return($program_ext, $module_ext); +} + +sub _mungeRegexp +{ + my ($regexp) = @_; + + grep(s"(^|[^\\])\."$1\x0\\."g, @$regexp); + grep(s"(^|[^\x0])\\\."$1\."g, @$regexp); + grep(s"\x0""g, @$regexp); +} + + +sub _error +{ + my ($type, @args) = @_; + + if ($type eq 'equal') + { + + if ($args[0] eq $args[1]) + { + _print ("ERROR: The object file '$args[0]' does not generate a legitimate executable file! Skipping!\n", -1); + return(1); + } + } + elsif ($type eq 'badeval') + { + if ($args[0]) + { + _print ("ERROR: $args[0]\n", -1); + return(1); + } + } + elsif ($type eq 'noextension') + { + my $progext = join(',', @{$args[1]}); + my $modext = join(',', @{$args[2]}); + + $progext =~ s"\\""g; + $modext =~ s"\\""g; + + $progext =~ s"\$""g; + $modext =~ s"\$""g; + + _print + ( +" +ERROR: '$args[0]' does not have a proper extension! Proper extensions are: + + PROGRAM: $progext + SHARED OBJECT: $modext + +Use the '-prog' flag to force your files to be interpreted as programs. +Use the '-mod' flag to force your files to be interpreted as modules. +", -1 + ); + return(1); + } + + return(0); +} + +sub _checkopts +{ + my @errors; + local($") = "\n"; + + if ($options->{'log'}) + { + $_fh = new FileHandle(">> $options->{'log'}") || push(@errors, "ERROR: Couldn't open $options->{'log'}\n"); + } + + if (($options->{'c'}) && (@ARGV > 1) && ($options->{'sav'} )) + { + push(@errors, +"ERROR: The '-sav' and '-C' options are incompatible when you have more than + one input file! ('-C' explicitly names resulting C code, '-sav' saves it, + and hence, with more than one file, the c code will be overwritten for + each file that you compile)\n"); + } + if (($options->{'o'}) && (@ARGV > 1)) + { + push(@errors, +"ERROR: The '-o' option is incompatible when you have more than one input file! + (-o explicitly names the resulting executable, hence, with more than + one file the names clash)\n"); + } + + if ($options->{'e'} && $options->{'sav'} && !$options->{'o'} && + !$options->{'C'}) + { + push(@errors, +"ERROR: You need to specify where you are going to save the resulting + executable or C code, when using '-sav' and '-e'. Use '-o' or '-C'.\n"); + } + + if (($options->{'regex'} || $options->{'run'} || $options->{'o'}) + && $options->{'gen'}) + { + push(@errors, +"ERROR: The options '-regex', '-run', and '-o' are incompatible with '-gen'. + '-gen' says to stop at C generation, and the other three modify the + compilation and/or running process!\n"); + } + + if ($options->{'run'} && $options->{'mod'}) + { + push(@errors, +"ERROR: Can't run modules that you are compiling! '-run' and '-mod' are + incompatible!\n"); + } + + if ($options->{'e'} && @ARGV) + { + push (@errors, +"ERROR: The option '-e' needs to be all by itself without any other + file arguments!\n"); + } + if ($options->{'e'} && !($options->{'o'} || $options->{'run'})) + { + $options->{'run'} = 1; + } + + if (!defined($options->{'verbose'})) + { + $options->{'verbose'} = ($options->{'log'})? 64 : 7; + } + + my $verbose_error; + + if ($options->{'verbose'} =~ m"[^tagfcd]" && + !( $options->{'verbose'} eq '0' || + ($options->{'verbose'} < 64 && $options->{'verbose'} > 0))) + { + $verbose_error = 1; + push(@errors, +"ERROR: Illegal verbosity level. Needs to have either the letters + 't','a','g','f','c', or 'd' in it or be between 0 and 63, inclusive.\n"); + } + + $options->{'verbose'} = ($options->{'verbose'} =~ m"[tagfcd]")? + ($options->{'verbose'} =~ m"d") * 32 + + ($options->{'verbose'} =~ m"c") * 16 + + ($options->{'verbose'} =~ m"f") * 8 + + ($options->{'verbose'} =~ m"t") * 4 + + ($options->{'verbose'} =~ m"a") * 2 + + ($options->{'verbose'} =~ m"g") * 1 + : $options->{'verbose'}; + + if (!$verbose_error && ( $options->{'log'} && + !( + ($options->{'verbose'} & 8) || + ($options->{'verbose'} & 16) || + ($options->{'verbose'} & 32 ) + ) + ) + ) + { + push(@errors, +"ERROR: The verbosity level '$options->{'verbose'}' does not output anything + to a logfile, and you specified '-log'!\n"); + } # } + + if (!$verbose_error && ( !$options->{'log'} && + ( + ($options->{'verbose'} & 8) || + ($options->{'verbose'} & 16) || + ($options->{'verbose'} & 32) || + ($options->{'verbose'} & 64) + ) + ) + ) + { + push(@errors, +"ERROR: The verbosity level '$options->{'verbose'}' requires that you also + specify a logfile via '-log'\n"); + } # } + + + (_print( "\n". join("\n", @errors), -1), return(0)) if (@errors); + return(1); +} + +sub _print +{ + my ($text, $flag ) = @_; + + my $logflag = int($flag/8) * 8; + my $regflag = $flag % 8; + + if ($flag == -1 || ($flag & $options->{'verbose'})) + { + my $dolog = ((($logflag & $options->{'verbose'}) || $flag == -1) + && $options->{'log'}); + + my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1); + + if ($doreg) { print( STDERR $text ); } + if ($dolog) { print $_fh $text; } + } +} + +sub _run +{ + my ($command, $flag) = @_; + + my $logflag = ($flag != -1)? int($flag/8) * 8 : 0; + my $regflag = $flag % 8; + + if ($flag == -1 || ($flag & $options->{'verbose'})) + { + my $dolog = ($logflag & $options->{'verbose'} && $options->{'log'}); + my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1); + + if ($doreg && !$dolog) + { system("$command"); } + + elsif ($doreg && $dolog) + { my $text = `$command 2>&1`; print $_fh $text; print STDERR $text;} + else + { my $text = `$command 2>&1`; print $_fh $text; } + } + else + { + `$command 2>&1`; + } + return($?); +} + +sub _usage +{ + _print + ( + <<"EOF" + +Usage: $0 <file_list> + + Flags with arguments + -L < extra library dirs for installation (form of 'dir1:dir2') > + -I < extra include dirs for installation (form of 'dir1:dir2') > + -C < explicit name of resulting C code > + -o < explicit name of resulting executable > + -e < to compile 'one liners'. Need executable name (-o) or '-run'> + -regex < rename regex, -regex 's/\.p/\.exe/' compiles a.p to a.exe > + -verbose < verbose level (1-63, or following letters 'gatfcd' > + -argv < arguments for the executables to be run via '-run' or '-e' > + + Boolean flags + -gen ( to just generate the c code. Implies '-sav' ) + -sav ( to save intermediate c code, (and executables with '-run')) + -run ( to run the compiled program on the fly, as were interpreted.) + -prog ( to indicate that the files on command line are programs ) + -mod ( to indicate that the files on command line are modules ) + +EOF +, -1 + + ); + exit(255); +} + + +__END__ + +=head1 NAME + +perlcc - frontend for perl compiler + +=head1 SYNOPSIS + + %prompt perlcc a.p # compiles into executable 'a' + + %prompt perlcc A.pm # compile into 'A.so' + + %prompt perlcc a.p -o execute # compiles 'a.p' into 'execute'. + + %prompt perlcc a.p -o execute -run # compiles 'a.p' into execute, runs on + # the fly + + %prompt perlcc a.p -o execute -run -argv 'arg1 arg2 arg3' + # compiles into execute, runs with + # arg1 arg2 arg3 as @ARGV + + %prompt perlcc a.p b.p c.p -regex 's/\.p/\.exe' + # compiles into 'a.exe','b.exe','c.exe'. + + %prompt perlcc a.p -log compilelog # compiles into 'a', saves compilation + # info into compilelog, as well + # as mirroring to screen + + %prompt perlcc a.p -log compilelog -verbose cdf + # compiles into 'a', saves compilation + # info into compilelog, being silent + # on screen. + + %prompt perlcc a.p -C a.c -gen # generates C code (into a.c) and + # stops without compile. + + %prompt perlcc a.p -L ../lib a.c + # Compiles with the perl libraries + # inside ../lib included. + +=head1 DESCRIPTION + +'perlcc' is the frontend into the perl compiler. Typing 'perlcc a.p' +compiles the code inside a.p into a standalone executable, and +perlcc A.pm will compile into a shared object, A.so, suitable for inclusion +into a perl program via "use A". + +There are quite a few flags to perlcc which help with such issues as compiling +programs in bulk, testing compiled programs for compatibility with the +interpreter, and controlling. + +=head1 OPTIONS + +=over 4 + +=item -L < library_directories > + +Adds directories in B<library_directories> to the compilation command. + +=item -I < include_directories > + +Adds directories inside B<include_directories> to the compilation command. + +=item -C < c_code_name > + +Explicitly gives the name B<c_code_name> to the generated c code which is to +be compiled. Can only be used if compiling one file on the command line. + +=item -o < executable_name > + +Explicitly gives the name B<executable_name> to the executable which is to be +compiled. Can only be used if compiling one file on the command line. + +=item -e < perl_line_to_execute> + +Compiles 'one liners', in the same way that B<perl -e> runs text strings at +the command line. Default is to have the 'one liner' be compiled, and run all +in one go (see B<-run>); giving the B<-o> flag saves the resultant executable, +rather than throwing it away. Use '-argv' to pass arguments to the executable +created. + +=item -regex <rename_regex> + +Gives a rule B<rename_regex> - which is a legal perl regular expression - to +create executable file names. + +=item -verbose <verbose_level> + +Show exactly what steps perlcc is taking to compile your code. You can change +the verbosity level B<verbose_level> much in the same way that the '-D' switch +changes perl's debugging level, by giving either a number which is the sum of +bits you want or a list of letters representing what you wish to see. Here are +the verbosity levels so far : + + Bit 1(g): Code Generation Errors to STDERR + Bit 2(a): Compilation Errors to STDERR + Bit 4(t): Descriptive text to STDERR + Bit 8(f): Code Generation Errors to file (B<-log> flag needed) + Bit 16(c): Compilation Errors to file (B<-log> flag needed) + Bit 32(d): Descriptive text to file (B<-log> flag needed) + +If the B<-log> tag is given, the default verbose level is 63 (ie: mirroring +all of perlcc's output to both the screen and to a log file). If no B<-log> +tag is given, then the default verbose level is 7 (ie: outputting all of +perlcc's output to STDERR). + +NOTE: Because of buffering concerns, you CANNOT shadow the output of '-run' to +both a file, and to the screen! Suggestions are welcome on how to overcome this +difficulty, but for now it simply does not work properly, and hence will only go +to the screen. + +=item -log <logname> + +Opens, for append, a logfile to save some or all of the text for a given +compile command. No rewrite version is available, so this needs to be done +manually. + +=item -argv <arguments> + +In combination with '-run' or '-e', tells perlcc to run the resulting +executable with the string B<arguments> as @ARGV. + +=item -sav + +Tells perl to save the intermediate C code. Usually, this C code is the name +of the perl code, plus '.c'; 'perlcode.p' gets generated in 'perlcode.p.c', +for example. If used with the '-e' operator, you need to tell perlcc where to +save resulting executables. + +=item -gen + +Tells perlcc to only create the intermediate C code, and not compile the +results. Does an implicit B<-sav>, saving the C code rather than deleting it. + +=item -run + +Immediately run the perl code that has been generated. NOTE: IF YOU GIVE THE +B<-run> FLAG TO B<perlcc>, THEN THE REST OF @ARGV WILL BE INTERPRETED AS +ARGUMENTS TO THE PROGRAM THAT YOU ARE COMPILING. + +=item -prog + +Indicate that the programs at the command line are programs, and should be +compiled as such. B<perlcc> will automatically determine files to be +programs if they have B<.p>, B<.pl>, B<.bat> extensions. + +=item -mod + +Indicate that the programs at the command line are modules, and should be +compiled as such. B<perlcc> will automatically determine files to be +modules if they have the extension B<.pm>. + +=back + +=head1 ENVIRONMENT + +Most of the work of B<perlcc> is done at the command line. However, you can +change the heuristic which determines what is a module and what is a program. +As indicated above, B<perlcc> assumes that the extensions: + +.p$, .pl$, and .bat$ + +indicate a perl program, and: + +.pm$ + +indicate a library, for the purposes of creating executables. And furthermore, +by default, these extensions will be replaced (and dropped ) in the process of +creating an executable. + +To change the extensions which are programs, and which are modules, set the +environmental variables: + +PERL_SCRIPT_EXT +PERL_MODULE_EXT + +These two environmental variables take colon-separated, legal perl regular +expressions, and are used by perlcc to decide which objects are which. +For example: + +setenv PERL_SCRIPT_EXT '.prl$:.perl$' +prompt% perlcc sample.perl + +will compile the script 'sample.perl' into the executable 'sample', and + +setenv PERL_MODULE_EXT '.perlmod$:.perlmodule$' + +prompt% perlcc sample.perlmod + +will compile the module 'sample.perlmod' into the shared object +'sample.so' + +NOTE: the '.' in the regular expressions for PERL_SCRIPT_EXT and PERL_MODULE_EXT +is a literal '.', and not a wild-card. To get a true wild-card, you need to +backslash the '.'; as in: + +setenv PERL_SCRIPT_EXT '\.\.\.\.\.' + +which would have the effect of compiling ANYTHING (except what is in +PERL_MODULE_EXT) into an executable with 5 less characters in its name. + +=head1 FILES + +'perlcc' uses a temporary file when you use the B<-e> option to evaluate +text and compile it. This temporary file is 'perlc$$.p'. The temporary C code is +perlc$$.p.c, and the temporary executable is perlc$$. + +When you use '-run' and don't save your executable, the temporary executable is +perlc$$ + +=head1 BUGS + +perlcc currently cannot compile shared objects on Win32. This should be fixed +by perl5.005. + +=cut + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 80a721cab1..60983b29a4 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -50,6 +50,7 @@ if(@ARGV<1) { die <<EOF; Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName $me -f PerlFunc + $me -q FAQKeywords The -h option prints more help. Also try "perldoc perldoc" to get aquainted with the system. @@ -73,6 +74,7 @@ sub usage{ die <<EOF; perldoc [options] PageName|ModuleName|ProgramName... perldoc [options] -f BuiltinFunction +perldoc [options] -q FAQRegex Options: -h Display this help message @@ -81,12 +83,13 @@ Options: -t Display pod using pod2text instead of pod2man and nroff (-t is the default on win32) -u Display unformatted pod text - -m Display modules file in its entirety - -l Display the modules file name + -m Display module's file in its entirety + -l Display the module's file name -F Arguments are file names, not modules -v Verbosely describe what's going on -X use index if present (looks for pod.idx at $Config{archlib}) + PageName|ModuleName... is the name of a piece of documentation that you want to look at. You may either give a descriptive name of the page (as in the case of @@ -97,7 +100,11 @@ PageName|ModuleName... BuiltinFunction is the name of a perl function. Will extract documentation from `perlfunc'. - + +FAQRegex + is a regex. Will search perlfaq[1-9] for and extract any + questions that match. + Any switches in the PERLDOC environment variable will be used before the command line arguments. The optional pod index file contains a list of filenames, one per line. @@ -110,7 +117,7 @@ use Text::ParseWords; unshift(@ARGV,shellwords($ENV{"PERLDOC"})); -getopts("mhtluvriFf:X") || usage; +getopts("mhtluvriFf:Xq") || usage; usage if $opt_h || $opt_h; # avoid -w warning @@ -127,6 +134,8 @@ if ($opt_t) { require Pod::Text; import Pod::Text; } if ($opt_f) { @pages = ("perlfunc"); +} elsif ($opt_q) { + @pages = ("perlfaq1" .. "perlfaq9"); } else { @pages = @ARGV; } @@ -359,6 +368,7 @@ if ($Is_MSWin32) { if ($^O eq 'os2') { require POSIX; $tmp = POSIX::tmpnam(); + unshift @pagers, 'less', 'cmd /c more <'; } else { $tmp = "/tmp/perldoc1.$$"; } @@ -398,14 +408,23 @@ if ($opt_f) { ++$found if /^\w/; # found descriptive text } if (@pod) { + my $lines = $ENV{LINES} || 24; + if ($opt_t) { open(FORMATTER, "| pod2text") || die "Can't start filter"; print FORMATTER "=over 8\n\n"; print FORMATTER @pod; print FORMATTER "=back\n"; close(FORMATTER); - } else { + } elsif (@pod < $lines-2) { print @pod; + } else { + foreach $pager (@pagers) { + open (PAGER, "| $pager") or next; + print PAGER @pod ; + close(PAGER) or next; + last; + } } } else { die "No documentation for perl function `$opt_f' found\n"; @@ -413,6 +432,39 @@ if ($opt_f) { exit; } +if ($opt_q) { + local @ARGV = @found; # I'm lazy, sue me. + my $found = 0; + my %found_in; + my @pod; + + while (<>) { + if (/^=head2\s+.*$opt_q/oi) { + $found = 1; + push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; + } elsif (/^=head2/) { + $found = 0; + } + next unless $found; + push @pod, $_; + } + + if (@pod) { + if ($opt_t) { + open(FORMATTER, "| pod2text") || die "Can't start filter"; + print FORMATTER "=over 8\n\n"; + print FORMATTER @pod; + print FORMATTER "=back\n"; + close(FORMATTER); + } else { + print @pod; + } + } else { + die "No documentation for perl function `$opt_f' found\n"; + } + exit; +} + foreach (@found) { if($opt_t) { @@ -546,7 +598,10 @@ command line arguments. C<perldoc> also searches directories specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not defined) and C<PATH> environment variables. (The latter is so that embedded pods for executables, such as -C<perldoc> itself, are available.) +C<perldoc> itself, are available.) C<perldoc> will use, in order of +preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or +C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not +used if C<perldoc> was told to display plain text or unformatted pod.) =head1 AUTHOR |