diff options
| author | markm <markm@FreeBSD.org> | 1998-09-09 07:00:04 +0000 |
|---|---|---|
| committer | markm <markm@FreeBSD.org> | 1998-09-09 07:00:04 +0000 |
| commit | 4fcbc3669aa997848e15198cc9fb856287a6788c (patch) | |
| tree | 58b20e81687d6d5931f120b50802ed21225bf440 /contrib/perl5/utils | |
| download | FreeBSD-src-4fcbc3669aa997848e15198cc9fb856287a6788c.zip FreeBSD-src-4fcbc3669aa997848e15198cc9fb856287a6788c.tar.gz | |
Initial import of Perl5. The king is dead; long live the king!
Diffstat (limited to 'contrib/perl5/utils')
| -rw-r--r-- | contrib/perl5/utils/Makefile | 43 | ||||
| -rw-r--r-- | contrib/perl5/utils/c2ph.PL | 1403 | ||||
| -rw-r--r-- | contrib/perl5/utils/h2ph.PL | 636 | ||||
| -rw-r--r-- | contrib/perl5/utils/h2xs.PL | 905 | ||||
| -rw-r--r-- | contrib/perl5/utils/perlbug.PL | 1093 | ||||
| -rw-r--r-- | contrib/perl5/utils/perlcc.PL | 945 | ||||
| -rw-r--r-- | contrib/perl5/utils/perldoc.PL | 687 | ||||
| -rw-r--r-- | contrib/perl5/utils/pl2pm.PL | 389 | ||||
| -rw-r--r-- | contrib/perl5/utils/splain.PL | 49 |
9 files changed, 6150 insertions, 0 deletions
diff --git a/contrib/perl5/utils/Makefile b/contrib/perl5/utils/Makefile new file mode 100644 index 0000000..2df16d8 --- /dev/null +++ b/contrib/perl5/utils/Makefile @@ -0,0 +1,43 @@ + +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 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) + +compile: all + $(REALPERL) -I../lib perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog; + +$(plextract): + $(PERL) -I../lib $@.PL + +c2ph: c2ph.PL ../config.sh + +h2ph: h2ph.PL ../config.sh + +h2xs: h2xs.PL ../config.sh + +perlbug: perlbug.PL ../config.sh ../patchlevel.h + +perldoc: perldoc.PL ../config.sh + +pl2pm: pl2pm.PL ../config.sh + +splain: splain.PL ../config.sh ../lib/diagnostics.pm + +perlcc: perlcc.PL ../config.sh + +clean: + +realclean: + rm -rf $(plextract) pstruct $(plextractexe) + +clobber: realclean + +distclean: clobber diff --git a/contrib/perl5/utils/c2ph.PL b/contrib/perl5/utils/c2ph.PL new file mode 100644 index 0000000..38b259f --- /dev/null +++ b/contrib/perl5/utils/c2ph.PL @@ -0,0 +1,1403 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# 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}. + +# 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. +$origdir = cwd; +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!'; +# +# +# c2ph (aka pstruct) +# Tom Christiansen, <tchrist@convex.com> +# +# As pstruct, dump C structures as generated from 'cc -g -S' stabs. +# As c2ph, do this PLUS generate perl code for getting at the structures. +# +# See the usage message for more. If this isn't enough, read the code. +# + +=head1 NAME + +c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs + +=head1 SYNOPSIS + + c2ph [-dpnP] [var=val] [files ...] + +=head2 OPTIONS + + Options: + + -w wide; short for: type_width=45 member_width=35 offset_width=8 + -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04 + + -n do not generate perl code (default when invoked as pstruct) + -p generate perl code (default when invoked as c2ph) + -v generate perl code, with C decls as comments + + -i do NOT recompute sizes for intrinsic datatypes + -a dump information on intrinsics also + + -t trace execution + -d spew reams of debugging output + + -slist give comma-separated list a structures to dump + +=head1 DESCRIPTION + +The following is the old c2ph.doc documentation by Tom Christiansen +<tchrist@perl.com> +Date: 25 Jul 91 08:10:21 GMT + +Once upon a time, I wrote a program called pstruct. It was a perl +program that tried to parse out C structures and display their member +offsets for you. This was especially useful for people looking at +binary dumps or poking around the kernel. + +Pstruct was not a pretty program. Neither was it particularly robust. +The problem, you see, was that the C compiler was much better at parsing +C than I could ever hope to be. + +So I got smart: I decided to be lazy and let the C compiler parse the C, +which would spit out debugger stabs for me to read. These were much +easier to parse. It's still not a pretty program, but at least it's more +robust. + +Pstruct takes any .c or .h files, or preferably .s ones, since that's +the format it is going to massage them into anyway, and spits out +listings like this: + + struct tty { + int tty.t_locker 000 4 + int tty.t_mutex_index 004 4 + struct tty * tty.t_tp_virt 008 4 + struct clist tty.t_rawq 00c 20 + int tty.t_rawq.c_cc 00c 4 + int tty.t_rawq.c_cmax 010 4 + int tty.t_rawq.c_cfx 014 4 + int tty.t_rawq.c_clx 018 4 + struct tty * tty.t_rawq.c_tp_cpu 01c 4 + struct tty * tty.t_rawq.c_tp_iop 020 4 + unsigned char * tty.t_rawq.c_buf_cpu 024 4 + unsigned char * tty.t_rawq.c_buf_iop 028 4 + struct clist tty.t_canq 02c 20 + int tty.t_canq.c_cc 02c 4 + int tty.t_canq.c_cmax 030 4 + int tty.t_canq.c_cfx 034 4 + int tty.t_canq.c_clx 038 4 + struct tty * tty.t_canq.c_tp_cpu 03c 4 + struct tty * tty.t_canq.c_tp_iop 040 4 + unsigned char * tty.t_canq.c_buf_cpu 044 4 + unsigned char * tty.t_canq.c_buf_iop 048 4 + struct clist tty.t_outq 04c 20 + int tty.t_outq.c_cc 04c 4 + int tty.t_outq.c_cmax 050 4 + int tty.t_outq.c_cfx 054 4 + int tty.t_outq.c_clx 058 4 + struct tty * tty.t_outq.c_tp_cpu 05c 4 + struct tty * tty.t_outq.c_tp_iop 060 4 + unsigned char * tty.t_outq.c_buf_cpu 064 4 + unsigned char * tty.t_outq.c_buf_iop 068 4 + (*int)() tty.t_oproc_cpu 06c 4 + (*int)() tty.t_oproc_iop 070 4 + (*int)() tty.t_stopproc_cpu 074 4 + (*int)() tty.t_stopproc_iop 078 4 + struct thread * tty.t_rsel 07c 4 + +etc. + + +Actually, this was generated by a particular set of options. You can control +the formatting of each column, whether you prefer wide or fat, hex or decimal, +leading zeroes or whatever. + +All you need to be able to use this is a C compiler than generates +BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC +should get this for you. + +To learn more, just type a bogus option, like B<-\?>, and a long usage message +will be provided. There are a fair number of possibilities. + +If you're only a C programmer, than this is the end of the message for you. +You can quit right now, and if you care to, save off the source and run it +when you feel like it. Or not. + + + +But if you're a perl programmer, then for you I have something much more +wondrous than just a structure offset printer. + +You see, if you call pstruct by its other incybernation, c2ph, you have a code +generator that translates C code into perl code! Well, structure and union +declarations at least, but that's quite a bit. + +Prior to this point, anyone programming in perl who wanted to interact +with C programs, like the kernel, was forced to guess the layouts of +the C strutures, and then hardwire these into his program. Of course, +when you took your wonderfully crafted program to a system where the +sgtty structure was laid out differently, you program broke. Which is +a shame. + +We've had Larry's h2ph translator, which helped, but that only works on +cpp symbols, not real C, which was also very much needed. What I offer +you is a symbolic way of getting at all the C structures. I've couched +them in terms of packages and functions. Consider the following program: + + #!/usr/local/bin/perl + + require 'syscall.ph'; + require 'sys/time.ph'; + require 'sys/resource.ph'; + + $ru = "\0" x &rusage'sizeof(); + + syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!"; + + @ru = unpack($t = &rusage'typedef(), $ru); + + $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ] + + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6; + + $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ] + + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6; + + printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime; + + +As you see, the name of the package is the name of the structure. Regular +fields are just their own names. Plus the following accessor functions are +provided for your convenience: + + struct This takes no arguments, and is merely the number of first-level + elements in the structure. You would use this for indexing + into arrays of structures, perhaps like this + + + $usec = $u[ &user'u_utimer + + (&ITIMER_VIRTUAL * &itimerval'struct) + + &itimerval'it_value + + &timeval'tv_usec + ]; + + sizeof Returns the bytes in the structure, or the member if + you pass it an argument, such as + + &rusage'sizeof(&rusage'ru_utime) + + typedef This is the perl format definition for passing to pack and + unpack. If you ask for the typedef of a nothing, you get + the whole structure, otherwise you get that of the member + you ask for. Padding is taken care of, as is the magic to + guarantee that a union is unpacked into all its aliases. + Bitfields are not quite yet supported however. + + offsetof This function is the byte offset into the array of that + member. You may wish to use this for indexing directly + into the packed structure with vec() if you're too lazy + to unpack it. + + typeof Not to be confused with the typedef accessor function, this + one returns the C type of that field. This would allow + you to print out a nice structured pretty print of some + structure without knoning anything about it beforehand. + No args to this one is a noop. Someday I'll post such + a thing to dump out your u structure for you. + + +The way I see this being used is like basically this: + + % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph + % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph + % install + +It's a little tricker with c2ph because you have to get the includes right. +I can't know this for your system, but it's not usually too terribly difficult. + +The code isn't pretty as I mentioned -- I never thought it would be a 1000- +line program when I started, or I might not have begun. :-) But I would have +been less cavalier in how the parts of the program communicated with each +other, etc. It might also have helped if I didn't have to divine the makeup +of the stabs on the fly, and then account for micro differences between my +compiler and gcc. + +Anyway, here it is. Should run on perl v4 or greater. Maybe less. + + + --tom + +=cut + +$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $'; + + +###################################################################### + +# some handy data definitions. many of these can be reset later. + +$bitorder = 'b'; # ascending; set to B for descending bit fields + +%intrinsics = +%template = ( + 'char', 'c', + 'unsigned char', 'C', + 'short', 's', + 'short int', 's', + 'unsigned short', 'S', + 'unsigned short int', 'S', + 'short unsigned int', 'S', + 'int', 'i', + 'unsigned int', 'I', + 'long', 'l', + 'long int', 'l', + 'unsigned long', 'L', + 'unsigned long', 'L', + 'long unsigned int', 'L', + 'unsigned long int', 'L', + 'long long', 'q', + 'long long int', 'q', + 'unsigned long long', 'Q', + 'unsigned long long int', 'Q', + 'float', 'f', + 'double', 'd', + 'pointer', 'p', + 'null', 'x', + 'neganull', 'X', + 'bit', $bitorder, +); + +&buildscrunchlist; +delete $intrinsics{'neganull'}; +delete $intrinsics{'bit'}; +delete $intrinsics{'null'}; + +# use -s to recompute sizes +%sizeof = ( + 'char', '1', + 'unsigned char', '1', + 'short', '2', + 'short int', '2', + 'unsigned short', '2', + 'unsigned short int', '2', + 'short unsigned int', '2', + 'int', '4', + 'unsigned int', '4', + 'long', '4', + 'long int', '4', + 'unsigned long', '4', + 'unsigned long int', '4', + 'long unsigned int', '4', + 'long long', '8', + 'long long int', '8', + 'unsigned long long', '8', + 'unsigned long long int', '8', + 'float', '4', + 'double', '8', + 'pointer', '4', +); + +($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); + +($offset_fmt, $size_fmt) = ('d', 'd'); + +$indent = 2; + +$CC = 'cc'; +$CFLAGS = '-g -S'; +$DEFINES = ''; + +$perl++ if $0 =~ m#/?c2ph$#; + +require 'getopts.pl'; + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +&Getopts('aixdpvtnws:') || &usage(0); + +$opt_d && $debug++; +$opt_t && $trace++; +$opt_p && $perl++; +$opt_v && $verbose++; +$opt_n && ($perl = 0); + +if ($opt_w) { + ($type_width, $member_width, $offset_width) = (45, 35, 8); +} +if ($opt_x) { + ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); +} + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +sub PLUMBER { + select(STDERR); + print "oops, apperent pager foulup\n"; + $isatty++; + &usage(1); +} + +sub usage { + local($oops) = @_; + unless (-t STDOUT) { + select(STDERR); + } elsif (!$oops) { + $isatty++; + $| = 1; + print "hit <RETURN> for further explanation: "; + <STDIN>; + open (PIPE, "|". ($ENV{PAGER} || 'more')); + $SIG{PIPE} = PLUMBER; + select(PIPE); + } + + print "usage: $0 [-dpnP] [var=val] [files ...]\n"; + + exit unless $isatty; + + print <<EOF; + +Options: + +-w wide; short for: type_width=45 member_width=35 offset_width=8 +-x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04 + +-n do not generate perl code (default when invoked as pstruct) +-p generate perl code (default when invoked as c2ph) +-v generate perl code, with C decls as comments + +-i do NOT recompute sizes for intrinsic datatypes +-a dump information on intrinsics also + +-t trace execution +-d spew reams of debugging output + +-slist give comma-separated list a structures to dump + + +Var Name Default Value Meaning + +EOF + + &defvar('CC', 'which_compiler to call'); + &defvar('CFLAGS', 'how to generate *.s files with stabs'); + &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U'); + + print "\n"; + + &defvar('type_width', 'width of type field (column 1)'); + &defvar('member_width', 'width of member field (column 2)'); + &defvar('offset_width', 'width of offset field (column 3)'); + &defvar('size_width', 'width of size field (column 4)'); + + print "\n"; + + &defvar('offset_fmt', 'sprintf format type for offset'); + &defvar('size_fmt', 'sprintf format type for size'); + + print "\n"; + + &defvar('indent', 'how far to indent each nesting level'); + + print <<'EOF'; + + If any *.[ch] files are given, these will be catted together into + a temporary *.c file and sent through: + $CC $CFLAGS $DEFINES + and the resulting *.s groped for stab information. If no files are + supplied, then stdin is read directly with the assumption that it + contains stab information. All other liens will be ignored. At + most one *.s file should be supplied. + +EOF + close PIPE; + exit 1; +} + +sub defvar { + local($var, $msg) = @_; + printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg; +} + +$recurse = 1; + +if (@ARGV) { + if (grep(!/\.[csh]$/,@ARGV)) { + warn "Only *.[csh] files expected!\n"; + &usage; + } + elsif (grep(/\.s$/,@ARGV)) { + if (@ARGV > 1) { + warn "Only one *.s file allowed!\n"; + &usage; + } + } + elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { + local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; + $chdir = "cd $dir; " if $dir; + &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; + $ARGV[0] =~ s/\.c$/.s/; + } + else { + $TMP = "/tmp/c2ph.$$.c"; + &system("cat @ARGV > $TMP") && exit 1; + &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; + unlink $TMP; + $TMP =~ s/\.c$/.s/; + @ARGV = ($TMP); + } +} + +if ($opt_s) { + for (split(/[\s,]+/, $opt_s)) { + $interested{$_}++; + } +} + + +$| = 1 if $debug; + +main: { + + if ($trace) { + if (-t && !@ARGV) { + print STDERR "reading from your keyboard: "; + } else { + print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": "; + } + } + +STAB: while (<>) { + if ($trace && !($. % 10)) { + $lineno = $..''; + print STDERR $lineno, "\b" x length($lineno); + } + next unless /^\s*\.stabs\s+/; + $line = $_; + s/^\s*\.stabs\s+//; + if (s/\\\\"[d,]+$//) { + $saveline .= $line; + $savebar = $_; + next STAB; + } + if ($saveline) { + s/^"//; + $_ = $savebar . $_; + $line = $saveline; + } + &stab; + $savebar = $saveline = undef; + } + print STDERR "$.\n" if $trace; + unlink $TMP if $TMP; + + &compute_intrinsics if $perl && !$opt_i; + + print STDERR "resolving types\n" if $trace; + + &resolve_types; + &adjust_start_addrs; + + $sum = 2 + $type_width + $member_width; + $pmask1 = "%-${type_width}s %-${member_width}s"; + $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; + + + + if ($perl) { + # resolve template -- should be in stab define order, but even this isn't enough. + print STDERR "\nbuilding type templates: " if $trace; + for $i (reverse 0..$#type) { + next unless defined($name = $type[$i]); + next unless defined $struct{$name}; + ($iname = $name) =~ s/\..*//; + $build_recursed = 0; + &build_template($name) unless defined $template{&psou($name)} || + $opt_s && !$interested{$iname}; + } + print STDERR "\n\n" if $trace; + } + + print STDERR "dumping structs: " if $trace; + + local($iam); + + + + foreach $name (sort keys %struct) { + ($iname = $name) =~ s/\..*//; + next if $opt_s && !$interested{$iname}; + print STDERR "$name " if $trace; + + undef @sizeof; + undef @typedef; + undef @offsetof; + undef @indices; + undef @typeof; + undef @fieldnames; + + $mname = &munge($name); + + $fname = &psou($name); + + print "# " if $perl && $verbose; + $pcode = ''; + print "$fname {\n" if !$perl || $verbose; + $template{$fname} = &scrunch($template{$fname}) if $perl; + &pstruct($name,$name,0); + print "# " if $perl && $verbose; + print "}\n" if !$perl || $verbose; + print "\n" if $perl && $verbose; + + if ($perl) { + print "$pcode"; + + printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); + + print <<EOF; +sub ${mname}'typedef { + local(\$${mname}'index) = shift; + defined \$${mname}'index + ? \$${mname}'typedef[\$${mname}'index] + : \$${mname}'typedef; +} +EOF + + print <<EOF; +sub ${mname}'sizeof { + local(\$${mname}'index) = shift; + defined \$${mname}'index + ? \$${mname}'sizeof[\$${mname}'index] + : \$${mname}'sizeof; +} +EOF + + print <<EOF; +sub ${mname}'offsetof { + local(\$${mname}'index) = shift; + defined \$${mname}index + ? \$${mname}'offsetof[\$${mname}'index] + : \$${mname}'sizeof; +} +EOF + + print <<EOF; +sub ${mname}'typeof { + local(\$${mname}'index) = shift; + defined \$${mname}index + ? \$${mname}'typeof[\$${mname}'index] + : '$name'; +} +EOF + + print <<EOF; +sub ${mname}'fieldnames { + \@${mname}'fieldnames; +} +EOF + + $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u'); + + print <<EOF; +sub ${mname}'isastruct { + '$iam'; +} +EOF + + print "\$${mname}'typedef = '" . &scrunch($template{$fname}) + . "';\n"; + + print "\$${mname}'sizeof = $sizeof{$name};\n\n"; + + + print "\@${mname}'indices = (", &squishseq(@indices), ");\n"; + + print "\n"; + + print "\@${mname}'typedef[\@${mname}'indices] = (", + join("\n\t", '', @typedef), "\n );\n\n"; + print "\@${mname}'sizeof[\@${mname}'indices] = (", + join("\n\t", '', @sizeof), "\n );\n\n"; + print "\@${mname}'offsetof[\@${mname}'indices] = (", + join("\n\t", '', @offsetof), "\n );\n\n"; + print "\@${mname}'typeof[\@${mname}'indices] = (", + join("\n\t", '', @typeof), "\n );\n\n"; + print "\@${mname}'fieldnames[\@${mname}'indices] = (", + join("\n\t", '', @fieldnames), "\n );\n\n"; + + $template_printed{$fname}++; + $size_printed{$fname}++; + } + print "\n"; + } + + print STDERR "\n" if $trace; + + unless ($perl && $opt_a) { + print "\n1;\n" if $perl; + exit; + } + + + + foreach $name (sort bysizevalue keys %intrinsics) { + next if $size_printed{$name}; + print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n"; + } + + print "\n"; + + sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; } + + + foreach $name (sort keys %intrinsics) { + print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; + } + + print "\n1;\n" if $perl; + + exit; +} + +######################################################################################## + + +sub stab { + next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun + s/"// || next; + s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; + + next if /^\s*$/; + + $size = $3 if $3; + $_ = $continued . $_ if length($continued); + if (s/\\\\$//) { + # if last 2 chars of string are '\\' then stab is continued + # in next stab entry + chop; + $continued = $_; + next; + } + $continued = ''; + + + $line = $_; + + if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { + print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; + &pdecl($pdecl); + next; + } + + + + if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { + local($ident) = $2; + push(@intrinsics, $ident); + $typeno = &typeno($3); + $type[$typeno] = $ident; + print STDERR "intrinsic $ident in new type $typeno\n" if $debug; + next; + } + + if (($name, $typeordef, $typeno, $extra, $struct, $_) + = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) + { + $typeno = &typeno($typeno); # sun foolery + } + elsif (/^[\$\w]+:/) { + next; # variable + } + else { + warn "can't grok stab: <$_> in: $line " if $_; + next; + } + + #warn "got size $size for $name\n"; + $sizeof{$name} = $size if $size; + + s/;[-\d]*;[-\d]*;$//; # we don't care about ranges + + $typenos{$name} = $typeno; + + unless (defined $type[$typeno]) { + &panic("type 0??") unless $typeno; + $type[$typeno] = $name unless defined $type[$typeno]; + printf "new type $typeno is $name" if $debug; + if ($extra =~ /\*/ && defined $type[$struct]) { + print ", a typedef for a pointer to " , $type[$struct] if $debug; + } + } else { + printf "%s is type %d", $name, $typeno if $debug; + print ", a typedef for " , $type[$typeno] if $debug; + } + print "\n" if $debug; + #next unless $extra =~ /[su*]/; + + #$type[$struct] = $name; + + if ($extra =~ /[us*]/) { + &sou($name, $extra); + $_ = &sdecl($name, $_, 0); + } + elsif (/^=ar/) { + print "it's a bare array typedef -- that's pretty sick\n" if $debug; + $_ = "$typeno$_"; + $scripts = ''; + $_ = &adecl($_,1); + + } + elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc + push(@intrinsics, $2); + $typeno = &typeno($3); + $type[$typeno] = $2; + print STDERR "intrinsic $2 in new type $typeno\n" if $debug; + } + elsif (s/^=e//) { # blessed be thy compiler; mine won't do this + &edecl; + } + else { + warn "Funny remainder for $name on line $_ left in $line " if $_; + } +} + +sub typeno { # sun thinks types are (0,27) instead of just 27 + local($_) = @_; + s/\(\d+,(\d+)\)/$1/; + $_; +} + +sub pstruct { + local($what,$prefix,$base) = @_; + local($field, $fieldname, $typeno, $count, $offset, $entry); + local($fieldtype); + local($type, $tname); + local($mytype, $mycount, $entry2); + local($struct_count) = 0; + local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); + local($bits,$bytes); + local($template); + + + local($mname) = &munge($name); + + sub munge { + local($_) = @_; + s/[\s\$\.]/_/g; + $_; + } + + local($sname) = &psou($what); + + $nesting++; + + for $field (split(/;/, $struct{$what})) { + $pad = $prepad = 0; + $entry = ''; + ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); + + $type = $type[$typeno]; + + $type =~ /([^[]*)(\[.*\])?/; + $mytype = $1; + $count .= $2; + $fieldtype = &psou($mytype); + + local($fname) = &psou($name); + + if ($build_templates) { + + $pad = ($offset - ($lastoffset + $lastlength))/8 + if defined $lastoffset; + + if (! $finished_template{$sname}) { + if ($isaunion{$what}) { + $template{$sname} .= 'X' x $revpad . ' ' if $revpad; + } else { + $template{$sname} .= 'x' x $pad . ' ' if $pad; + } + } + + $template = &fetch_template($type); + &repeat_template($template,$count); + + if (! $finished_template{$sname}) { + $template{$sname} .= $template; + } + + $revpad = $length/8 if $isaunion{$what}; + + ($lastoffset, $lastlength) = ($offset, $length); + + } else { + print '# ' if $perl && $verbose; + $entry = sprintf($pmask1, + ' ' x ($nesting * $indent) . $fieldtype, + "$prefix.$fieldname" . $count); + + $entry =~ s/(\*+)( )/$2$1/; + + printf $pmask2, + $entry, + ($base+$offset)/8, + ($bits = ($base+$offset)%8) ? ".$bits" : " ", + $length/8, + ($bits = $length % 8) ? ".$bits": "" + if !$perl || $verbose; + + if ($perl) { + $template = &fetch_template($type); + &repeat_template($template,$count); + } + + if ($perl && $nesting == 1) { + + push(@sizeof, int($length/8) .",\t# $fieldname"); + push(@offsetof, int($offset/8) .",\t# $fieldname"); + local($little) = &scrunch($template); + push(@typedef, "'$little', \t# $fieldname"); + $type =~ s/(struct|union) //; + push(@typeof, "'$mytype" . ($count ? $count : '') . + "',\t# $fieldname"); + push(@fieldnames, "'$fieldname',"); + } + + print ' ', ' ' x $indent x $nesting, $template + if $perl && $verbose; + + print "\n" if !$perl || $verbose; + + } + if ($perl) { + local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; + $mycount *= &scripts2count($count) if $count; + if ($nesting==1 && !$build_templates) { + $pcode .= sprintf("sub %-32s { %4d; }\n", + "${mname}'${fieldname}", $struct_count); + push(@indices, $struct_count); + } + $struct_count += $mycount; + } + + + &pstruct($type, "$prefix.$fieldname", $base+$offset) + if $recurse && defined $struct{$type}; + } + + $countof{$what} = $struct_count unless defined $countof{$whati}; + + $template{$sname} .= '$' if $build_templates; + $finished_template{$sname}++; + + if ($build_templates && !defined $sizeof{$name}) { + local($fmt) = &scrunch($template{$sname}); + print STDERR "no size for $name, punting with $fmt..." if $debug; + eval '$sizeof{$name} = length(pack($fmt, ()))'; + if ($@) { + chop $@; + warn "couldn't get size for \$name: $@"; + } else { + print STDERR $sizeof{$name}, "\n" if $debUg; + } + } + + --$nesting; +} + + +sub psize { + local($me) = @_; + local($amstruct) = $struct{$me} ? 'struct ' : ''; + + print '$sizeof{\'', $amstruct, $me, '\'} = '; + printf "%d;\n", $sizeof{$me}; +} + +sub pdecl { + local($pdecl) = @_; + local(@pdecls); + local($tname); + + warn "pdecl: $pdecl\n" if $debug; + + $pdecl =~ s/\(\d+,(\d+)\)/$1/g; + $pdecl =~ s/\*//g; + @pdecls = split(/=/, $pdecl); + $typeno = $pdecls[0]; + $tname = pop @pdecls; + + if ($tname =~ s/^f//) { $tname = "$tname&"; } + #else { $tname = "$tname*"; } + + for (reverse @pdecls) { + $tname .= s/^f// ? "&" : "*"; + #$tname =~ s/^f(.*)/$1&/; + print "type[$_] is $tname\n" if $debug; + $type[$_] = $tname unless defined $type[$_]; + } +} + + + +sub adecl { + ($arraytype, $unknown, $lower, $upper) = (); + #local($typeno); + # global $typeno, @type + local($_, $typedef) = @_; + + while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) { + ($arraytype, $unknown) = ($2, $3); + $arraytype = &typeno($arraytype); + $unknown = &typeno($unknown); + if (s/^(\d+);(\d+);//) { + ($lower, $upper) = ($1, $2); + $scripts .= '[' . ($upper+1) . ']'; + } else { + warn "can't find array bounds: $_"; + } + } + if (s/^([(,)\d*f=]*),(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + $whatis = $1; + if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) { + $typeno = &typeno($1); + &pdecl($whatis); + } else { + $typeno = &typeno($whatis); + } + } elsif (s/^(\d+)(=[*suf]\d*)//) { + local($whatis) = $2; + + if ($whatis =~ /[f*]/) { + &pdecl($whatis); + } elsif ($whatis =~ /[su]/) { # + print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" + if $debug; + #$type[$typeno] = $name unless defined $type[$typeno]; + ##printf "new type $typeno is $name" if $debug; + $typeno = $1; + $type[$typeno] = "$prefix.$fieldname"; + local($name) = $type[$typeno]; + &sou($name, $whatis); + $_ = &sdecl($name, $_, $start+$offset); + 1; + $start = $start{$name}; + $offset = $sizeof{$name}; + $length = $offset; + } else { + warn "what's this? $whatis in $line "; + } + } elsif (/^\d+$/) { + $typeno = $_; + } else { + warn "bad array stab: $_ in $line "; + next STAB; + } + #local($wasdef) = defined($type[$typeno]) && $debug; + #if ($typedef) { + #print "redefining $type[$typeno] to " if $wasdef; + #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; + #print "$type[$typeno]\n" if $wasdef; + #} else { + #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; + #} + $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; + print "type[$arraytype] is $type[$arraytype]\n" if $debug; + print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; + $_; +} + + + +sub sdecl { + local($prefix, $_, $offset) = @_; + + local($fieldname, $scripts, $type, $arraytype, $unknown, + $whatis, $pdecl, $upper,$lower, $start,$length) = (); + local($typeno,$sou); + + +SFIELD: + while (/^([^;]+);/) { + $scripts = ''; + warn "sdecl $_\n" if $debug; + if (s/^([\$\w]+)://) { + $fieldname = $1; + } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # + $typeno = &typeno($1); + $type[$typeno] = "$prefix.$fieldname"; + local($name) = "$prefix.$fieldname"; + &sou($name,$2); + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $offset += $sizeof{$name}; + #print "done with anon, start is $start, offset is $offset\n"; + #next SFIELD; + } else { + warn "weird field $_ of $line" if $debug; + next STAB; + #$fieldname = &gensym; + #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + } + + if (/^(\d+|\(\d+,\d+\))=ar/) { + $_ = &adecl($_); + } + elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + &panic("no length?") unless $length; + $typeno = &typeno($1) if $1; + } + elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + &panic("no length?") unless $length; + $typeno = &typeno($1) if $1; + } + elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { + ($pdecl, $start, $length) = ($1,$5,$6); + &pdecl($pdecl); + } + elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct + ($typeno, $sou) = ($1, $2); + $typeno = &typeno($typeno); + if (defined($type[$typeno])) { + warn "now how did we get type $1 in $fieldname of $line?"; + } else { + print "anon type $typeno is $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; + }; + local($name) = "$prefix.$fieldname"; + &sou($name,$sou); + print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname"; + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $length = $sizeof{$name}; + } + else { + warn "can't grok stab for $name ($_) in line $line "; + next STAB; + } + + &panic("no length for $prefix.$fieldname") unless $length; + $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; + } + if (s/;\d*,(\d+),(\d+);//) { + local($start, $size) = ($1, $2); + $sizeof{$prefix} = $size; + print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; + $start{$prefix} = $start; + } + $_; +} + +sub edecl { + s/;$//; + $enum{$name} = $_; + $_ = ''; +} + +sub resolve_types { + local($sou); + for $i (0 .. $#type) { + next unless defined $type[$i]; + $_ = $type[$i]; + unless (/\d/) { + print "type[$i] $type[$i]\n" if $debug; + next; + } + print "type[$i] $_ ==> " if $debug; + s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; + s/^(\d+)\&/&type($1)/e; + s/^(\d+)/&type($1)/e; + s/(\*+)([^*]+)(\*+)/$1$3$2/; + s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; + s/^(\d+)([\*\[].*)/&type($1).$2/e; + #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; + $type[$i] = $_; + print "$_\n" if $debug; + } +} +sub type { &psou($type[$_[0]] || "<UNDEFINED>"); } + +sub adjust_start_addrs { + for (sort keys %start) { + ($basename = $_) =~ s/\.[^.]+$//; + $start{$_} += $start{$basename}; + print "start: $_ @ $start{$_}\n" if $debug; + } +} + +sub sou { + local($what, $_) = @_; + /u/ && $isaunion{$what}++; + /s/ && $isastruct{$what}++; +} + +sub psou { + local($what) = @_; + local($prefix) = ''; + if ($isaunion{$what}) { + $prefix = 'union '; + } elsif ($isastruct{$what}) { + $prefix = 'struct '; + } + $prefix . $what; +} + +sub scrunch { + local($_) = @_; + + return '' if $_ eq ''; + + study; + + s/\$//g; + s/ / /g; + 1 while s/(\w) \1/$1$1/g; + + # i wanna say this, but perl resists my efforts: + # s/(\w)(\1+)/$2 . length($1)/ge; + + &quick_scrunch; + + s/ $//; + + $_; +} + +sub buildscrunchlist { + $scrunch_code = "sub quick_scrunch {\n"; + for (values %intrinsics) { + $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n"; + } + $scrunch_code .= "}\n"; + print "$scrunch_code" if $debug; + eval $scrunch_code; + &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; +} + +sub fetch_template { + local($mytype) = @_; + local($fmt); + local($count) = 1; + + &panic("why do you care?") unless $perl; + + if ($mytype =~ s/(\[\d+\])+$//) { + $count .= $1; + } + + if ($mytype =~ /\*/) { + $fmt = $template{'pointer'}; + } + elsif (defined $template{$mytype}) { + $fmt = $template{$mytype}; + } + elsif (defined $struct{$mytype}) { + if (!defined $template{&psou($mytype)}) { + &build_template($mytype) unless $mytype eq $name; + } + elsif ($template{&psou($mytype)} !~ /\$$/) { + #warn "incomplete template for $mytype\n"; + } + $fmt = $template{&psou($mytype)} || '?'; + } + else { + warn "unknown fmt for $mytype\n"; + $fmt = '?'; + } + + $fmt x $count . ' '; +} + +sub compute_intrinsics { + local($TMP) = "/tmp/c2ph-i.$$.c"; + open (TMP, ">$TMP") || die "can't open $TMP: $!"; + select(TMP); + + print STDERR "computing intrinsic sizes: " if $trace; + + undef %intrinsics; + + print <<'EOF'; +main() { + char *mask = "%d %s\n"; +EOF + + for $type (@intrinsics) { + next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff + print <<"EOF"; + printf(mask,sizeof($type), "$type"); +EOF + } + + print <<'EOF'; + printf(mask,sizeof(char *), "pointer"); + exit(0); +} +EOF + close TMP; + + select(STDOUT); + open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); + while (<PIPE>) { + chop; + split(' ',$_,2);; + print "intrinsic $_[1] is size $_[0]\n" if $debug; + $sizeof{$_[1]} = $_[0]; + $intrinsics{$_[1]} = $template{$_[0]}; + } + close(PIPE) || die "couldn't read intrinsics!"; + unlink($TMP, '/tmp/a.out'); + print STDERR "done\n" if $trace; +} + +sub scripts2count { + local($_) = @_; + + s/^\[//; + s/\]$//; + s/\]\[/*/g; + $_ = eval; + &panic("$_: $@") if $@; + $_; +} + +sub system { + print STDERR "@_\n" if $trace; + system @_; +} + +sub build_template { + local($name) = @_; + + &panic("already got a template for $name") if defined $template{$name}; + + local($build_templates) = 1; + + local($lparen) = '(' x $build_recursed; + local($rparen) = ')' x $build_recursed; + + print STDERR "$lparen$name$rparen " if $trace; + $build_recursed++; + &pstruct($name,$name,0); + print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; + --$build_recursed; +} + + +sub panic { + + select(STDERR); + + print "\npanic: @_\n"; + + exit 1 if $] <= 4.003; # caller broken + + local($i,$_); + local($p,$f,$l,$s,$h,$a,@a,@sub); + for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = @DB'args; + for (@a) { + if (/^StB\000/ && length($_) == length($_main{'_main'})) { + $_ = sprintf("%s",$_); + } + else { + s/'/\\'/g; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + push(@sub, "$w&$s$a from file $f line $l\n"); + last if $signal; + } + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + print $sub[$i]; + } + exit 1; +} + +sub squishseq { + local($num); + local($last) = -1e8; + local($string); + local($seq) = '..'; + + while (defined($num = shift)) { + if ($num == ($last + 1)) { + $string .= $seq unless $inseq++; + $last = $num; + next; + } elsif ($inseq) { + $string .= $last unless $last == -1e8; + } + + $string .= ',' if defined $string; + $string .= $num; + $last = $num; + $inseq = 0; + } + $string .= $last if $inseq && $last != -e18; + $string; +} + +sub repeat_template { + # local($template, $scripts) = @_; have to change caller's values + + if ( $_[1] ) { + local($ncount) = &scripts2count($_[1]); + if ($_[0] =~ /^\s*c\s*$/i) { + $_[0] = "A$ncount "; + $_[1] = ''; + } else { + $_[0] = $template x $ncount; + } + } +} +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +unlink 'pstruct'; +print "Linking c2ph to pstruct.\n"; +if (defined $Config{d_link}) { + link 'c2ph', 'pstruct'; +} else { + unshift @INC, '../lib'; + require File::Copy; + File::Copy::syscopy('c2ph', 'pstruct'); +} +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/contrib/perl5/utils/h2ph.PL b/contrib/perl5/utils/h2ph.PL new file mode 100644 index 0000000..066f2c9 --- /dev/null +++ b/contrib/perl5/utils/h2ph.PL @@ -0,0 +1,636 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(basename dirname); +use Cwd; + +# 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. +$origdir = cwd; +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 File::Path qw(mkpath); +use Getopt::Std; + +getopts('Dd:rlhaQ'); +die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); +@inc_dirs = inc_dirs() if $opt_a; + +my $Exit = 0; + +my $Dest_dir = $opt_d || $Config{installsitearch}; +die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" + unless -d $Dest_dir; + +@isatype = split(' ',<<END); + char uchar u_char + short ushort u_short + int uint u_int + long ulong u_long + FILE key_t caddr_t +END + +@isatype{@isatype} = (1) x @isatype; +$inif = 0; + +@ARGV = ('-') unless @ARGV; + +while (defined ($file = next_file())) { + if (-l $file and -d $file) { + link_if_possible($file) if ($opt_l); + next; + } + + # Recover from header files with unbalanced cpp directives + $t = ''; + $tab = 0; + + # $eval_index goes into ``#line'' directives, to help locate syntax errors: + $eval_index = 1; + + if ($file eq '-') { + open(IN, "-"); + open(OUT, ">-"); + } else { + ($outfile = $file) =~ s/\.h$/.ph/ || next; + print "$file -> $outfile\n" unless $opt_Q; + if ($file =~ m|^(.*)/|) { + $dir = $1; + mkpath "$Dest_dir/$dir"; + } + + if ($opt_a) { # automagic mode: locate header file in @inc_dirs + foreach (@inc_dirs) { + chdir $_; + last if -f $file; + } + } + + open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); + open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; + } + while (<IN>) { + chop; + while (/\\$/) { + chop; + $_ .= <IN>; + chop; + } + print OUT "# $_\n" if $opt_D; + if (s:/\*:\200:g) { + s:\*/:\201:g; + s/\200[^\201]*\201//g; # delete single line comments + if (s/\200.*//) { # begin multi-line comment? + $_ .= '/*'; + $_ .= <IN>; + redo; + } + } + if (s/^\s*\#\s*//) { + if (s/^define\s+(\w+)//) { + $name = $1; + $new = ''; + s/\s+$//; + if (s/^\(([\w,\s]*)\)//) { + $args = $1; + my $proto = '() '; + if ($args ne '') { + $proto = ''; + foreach $arg (split(/,\s*/,$args)) { + $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; + $curargs{$arg} = 1; + } + $args =~ s/\b(\w)/\$$1/g; + $args = "local($args) = \@_;\n$t "; + } + s/^\s+//; + expr(); + $new =~ s/(["\\])/\\$1/g; #"]); + $new = reindent($new); + $args = reindent($args); + if ($t ne '') { + $new =~ s/(['\\])/\\$1/g; #']); + if ($opt_h) { + print OUT $t, + "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 q($new);\n$t}' unless defined(\&$name);\n"; + } + } else { + print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n"; + } + %curargs = (); + } else { + s/^\s+//; + expr(); + $new = 1 if $new eq ''; + $new = reindent($new); + $args = reindent($args); + if ($t ne '') { + $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)) {\n sub $name () {\t",$new,";}\n}\n"; + } + } + } elsif (/^(include|import)\s*[<"](.*)[>"]/) { + ($incl = $2) =~ s/\.h$/.ph/; + print OUT $t,"require '$incl';\n"; + } elsif(/^include_next\s*[<"](.*)[>"]/) { + ($incl = $1) =~ s/\.h$/.ph/; + print OUT ($t, + "eval {\n"); + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT ($t, + "my(\%INCD) = map { \$INC{\$_} => 1 } ", + "(grep { \$_ eq \"$incl\" } keys(\%INC));\n"); + print OUT ($t, + "my(\@REM) = map { \"\$_/$incl\" } ", + "(grep { not exists(\$INCD{\"\$_/$incl\"})", + "and -f \"\$_/$incl\" } \@INC);\n"); + print OUT ($t, + "require \"\$REM[0]\" if \@REM;\n"); + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT ($t, + "};\n"); + print OUT ($t, + "warn(\$\@) if \$\@;\n"); + } elsif (/^ifdef\s+(\w+)/) { + print OUT $t,"if(defined(&$1)) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } 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"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } elsif (s/^elif\s+//) { + $new = ''; + $inif = 1; + expr(); + $inif = 0; + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n elsif($new) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } elsif (/^else/) { + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"} else {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } 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"; + } + } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?\{/) { + until(/\}.*?;/) { + chomp($next = <IN>); + $_ .= $next; + print OUT "# $next\n" if $opt_D; + } + s@/\*.*?\*/@@g; + s/\s+/ /g; + /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/; + ($enum_subs = $3) =~ s/\s//g; + @enum_subs = split(/,/, $enum_subs); + $enum_val = -1; + for $enum (@enum_subs) { + ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/; + $enum_value =~ s/^=//; + $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1); + if ($opt_h) { + print OUT ($t, + "eval(\"\\n#line $eval_index $outfile\\n", + "sub $enum_name () \{ $enum_val; \}\") ", + "unless defined(\&$enum_name);\n"); + ++ $eval_index; + } else { + print OUT ($t, + "eval(\"sub $enum_name () \{ $enum_val; \}\") ", + "unless defined(\&$enum_name);\n"); + } + } + } + } + print OUT "1;\n"; + + $is_converted{$file} = 1; + queue_includes_from($file) if ($opt_a); +} + +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/^\&([\(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;}; + s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;}; + s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; + s/^'((\\"|[^"])*)'// && do { + if ($curargs{$1}) { + $new .= "ord('\$$1')"; + } else { + $new .= "ord('$1')"; + } + next; + }; + # replace "sizeof(foo)" with "{foo}" + # also, remove * (C dereference operator) to avoid perl syntax + # problems. Where the %sizeof array comes from is anyone's + # guess (c2ph?), but this at least avoids fatal syntax errors. + # Behavior is undefined if sizeof() delimiters are unbalanced. + # This code was modified to able to handle constructs like this: + # sizeof(*(p)), which appear in the HP-UX 10.01 header files. + s/^sizeof\s*\(// && do { + $new .= '$sizeof'; + my $lvl = 1; # already saw one open paren + # tack { on the front, and skip it in the loop + $_ = "{" . "$_"; + my $index = 1; + # find balanced closing paren + while ($index <= length($_) && $lvl > 0) { + $lvl++ if substr($_, $index, 1) eq "("; + $lvl-- if substr($_, $index, 1) eq ")"; + $index++; + } + # tack } on the end, replacing ) + substr($_, $index - 1, 1) = "}"; + # remove pesky * operators within the sizeof argument + substr($_, 0, $index - 1) =~ s/\*//g; + next; + }; + # Eliminate typedefs + /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do { + foreach (split /\s+/, $1) { # Make sure all the words are types, + last unless ($isatype{$_} or $_ eq 'struct'); + } + s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. + }; + # struct/union member, including arrays: + s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { + $id = $1; + $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; + if ($id eq 'struct') { + s/^\s+(\w+)//; + $id .= ' ' . $1; + $isatype{$id} = 1; + } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { + while (s/^\s+(\w+)//) { $id .= ' ' . $1; } + $isatype{$id} = 1; + } + if ($curargs{$id}) { + $new .= "\$$id"; + $new .= '->' if /^[\[\{]/; + } elsif ($id eq 'defined') { + $new .= 'defined'; + } elsif (/^\(/) { + s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat + $new .= " &$id"; + } elsif ($isatype{$id}) { + if ($new =~ /{\s*$/) { + $new .= "'$id'"; + } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { + $new =~ s/\(\s*$//; + s/^[\s*]*\)//; + } else { + $new .= q(').$id.q('); + } + } else { + if ($inif && $new !~ /defined\s*\($/) { + $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; + } elsif (/^\[/) { + $new .= " \$$id"; + } else { + $new .= ' &' . $id; + } + } + next; + }; + s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;}; + } +} + + +# Handle recursive subdirectories without getting a grotesquely big stack. +# Could this be implemented using File::Find? +sub next_file +{ + my $file; + + while (@ARGV) { + $file = shift @ARGV; + + if ($file eq '-' or -f $file or -l $file) { + return $file; + } elsif (-d $file) { + if ($opt_r) { + expand_glob($file); + } else { + print STDERR "Skipping directory `$file'\n"; + } + } elsif ($opt_a) { + return $file; + } else { + print STDERR "Skipping `$file': not a file or directory\n"; + } + } + + return undef; +} + + +# Put all the files in $directory into @ARGV for processing. +sub expand_glob +{ + my ($directory) = @_; + + $directory =~ s:/$::; + + opendir DIR, $directory; + foreach (readdir DIR) { + next if ($_ eq '.' or $_ eq '..'); + + # 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/$_" } + } + closedir DIR; +} + + +# Given $file, a symbolic link to a directory in the C include directory, +# make an equivalent symbolic link in $Dest_dir, if we can figure out how. +# Otherwise, just duplicate the file or directory. +sub link_if_possible +{ + my ($dirlink) = @_; + my $target = eval 'readlink($dirlink)'; + + if ($target =~ m:^\.\./: or $target =~ m:^/:) { + # The target of a parent or absolute link could leave the $Dest_dir + # hierarchy, so let's put all of the contents of $dirlink (actually, + # the contents of $target) into @ARGV; as a side effect down the + # line, $dirlink will get created as an _actual_ directory. + expand_glob($dirlink); + } else { + if (-l "$Dest_dir/$dirlink") { + 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"; + + # Make sure that the link _links_ to something: + if (! -e "$Dest_dir/$target") { + mkpath("$Dest_dir/$target", 0755) or + print STDERR "Could not create $Dest_dir/$target/\n"; + } + } else { + print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n"; + } + } +} + + +# Push all #included files in $file onto our stack, except for STDIN +# and files we've already processed. +sub queue_includes_from +{ + my ($file) = @_; + my $line; + + return if ($file eq "-"); + + open HEADER, $file or return; + while (defined($line = <HEADER>)) { + while (/\\$/) { # Handle continuation lines + chop $line; + $line .= <HEADER>; + } + + if ($line =~ /^#\s*include\s+<(.*?)>/) { + push(@ARGV, $1) unless $is_converted{$1}; + } + } + close HEADER; +} + + +# Determine include directories; $Config{usrinc} should be enough for (all +# non-GCC?) C compilers, but gcc uses an additional include directory. +sub inc_dirs +{ + my $from_gcc = `$Config{cc} -v 2>&1`; + $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s; + + length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc}); +} + + +1; + +############################################################################## +__END__ + +=head1 NAME + +h2ph - convert .h C header files to .ph Perl header files + +=head1 SYNOPSIS + +B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]> + +=head1 DESCRIPTION + +I<h2ph> +converts any C header files specified to the corresponding Perl header file +format. +It is most easily run while in /usr/include: + + cd /usr/include; h2ph * sys/* + +or + + cd /usr/include; h2ph -r -l . + +The output files are placed in the hierarchy rooted at Perl's +architecture dependent library directory. You can specify a different +hierarchy with a B<-d> switch. + +If run with no arguments, filters standard input to standard output. + +=head1 OPTIONS + +=over 4 + +=item -d destination_dir + +Put the resulting B<.ph> files beneath B<destination_dir>, instead of +beneath the default Perl library location (C<$Config{'installsitsearch'}>). + +=item -r + +Run recursively; if any of B<headerfiles> are directories, then run I<h2ph> +on all files in those directories (and their subdirectories, etc.). B<-r> +and B<-a> are mutually exclusive. + +=item -a + +Run automagically; convert B<headerfiles>, as well as any B<.h> files +which they include. This option will search for B<.h> files in all +directories which your C compiler ordinarily uses. B<-a> and B<-r> are +mutually exclusive. + +=item -l + +Symbolic links will be replicated in the destination directory. If B<-l> +is not specified, then links are skipped over. + +=item -h + +Put ``hints'' in the .ph files which will help in locating problems with +I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax +errors, instead of the cryptic + + [ some error condition ] at (eval mmm) line nnn + +you will see the slightly more helpful + + [ some error condition ] at filename.ph line nnn + +However, the B<.ph> files almost double in size when built using B<-h>. + +=item -D + +Include the code from the B<.h> file as a comment in the B<.ph> file. +This is primarily used for debugging I<h2ph>. + +=back + +=head1 ENVIRONMENT + +No environment variables are used. + +=head1 FILES + + /usr/include/*.h + /usr/include/sys/*.h + +etc. + +=head1 AUTHOR + +Larry Wall + +=head1 SEE ALSO + +perl(1) + +=head1 DIAGNOSTICS + +The usual warnings if it can't read or write the files involved. + +=head1 BUGS + +Doesn't construct the %sizeof array for you. + +It doesn't handle all C constructs, but it does attempt to isolate +definitions inside evals so that you can get at the definitions +that it can translate. + +It's only intended as a rough tool. +You may need to dicker with the files produced. + +=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 ':'; +chdir $origdir; diff --git a/contrib/perl5/utils/h2xs.PL b/contrib/perl5/utils/h2xs.PL new file mode 100644 index 0000000..52f590b --- /dev/null +++ b/contrib/perl5/utils/h2xs.PL @@ -0,0 +1,905 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# 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}. + +# 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. +$origdir = cwd; +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!'; + +=head1 NAME + +h2xs - convert .h C header files to Perl extensions + +=head1 SYNOPSIS + +B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]] + +B<h2xs> B<-h> + +=head1 DESCRIPTION + +I<h2xs> builds a Perl extension from C header files. The extension +will include functions which can be used to retrieve the value of any +#define statement which was in the C header files. + +The I<module_name> will be used for the name of the extension. If +module_name is not supplied then the name of the first header file +will be used, with the first character capitalized. + +If the extension might need extra libraries, they should be included +here. The extension Makefile.PL will take care of checking whether +the libraries actually exist and how they should be loaded. +The extra libraries should be specified in the form -lm -lposix, etc, +just as on the cc command line. By default, the Makefile.PL will +search through the library path determined by Configure. That path +can be augmented by including arguments of the form B<-L/another/library/path> +in the extra-libraries argument. + +=head1 OPTIONS + +=over 5 + +=item B<-A> + +Omit all autoload facilities. This is the same as B<-c> but also removes the +S<C<require AutoLoader>> statement from the .pm file. + +=item B<-F> + +Additional flags to specify to C preprocessor when scanning header for +function declarations. Should not be used without B<-x>. + +=item B<-O> + +Allows a pre-existing extension directory to be overwritten. + +=item B<-P> + +Omit the autogenerated stub POD section. + +=item B<-X> + +Omit the XS portion. Used to generate templates for a module which is not +XS-based. + +=item B<-c> + +Omit C<constant()> from the .xs file and corresponding specialised +C<AUTOLOAD> from the .pm file. + +=item B<-d> + +Turn on debugging messages. + +=item B<-f> + +Allows an extension to be created for a header even if that header is +not found in /usr/include. + +=item B<-h> + +Print the usage, help and version for this h2xs and exit. + +=item B<-n> I<module_name> + +Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> + +=item B<-p> I<prefix> + +Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_> +This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are +autoloaded via the C<constant()> mechansim. + +=item B<-s> I<sub1,sub2> + +Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine. +These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>. + +=item B<-v> I<version> + +Specify a version number for this extension. This version number is added +to the templates. The default is 0.01. + +=item B<-x> + +Automatically generate XSUBs basing on function declarations in the +header file. The package C<C::Scan> should be installed. If this +option is specified, the name of the header file may look like +C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string, +but XSUBs are emitted only for the declarations included from file NAME2. + +Note that some types of arguments/return-values for functions may +result in XSUB-declarations/typemap-entries which need +hand-editing. Such may be objects which cannot be converted from/to a +pointer (like C<long long>), pointers to functions, or arrays. + +=back + +=head1 EXAMPLES + + + # Default behavior, extension is Rusers + h2xs rpcsvc/rusers + + # Same, but extension is RUSERS + h2xs -n RUSERS rpcsvc/rusers + + # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h> + h2xs rpcsvc::rusers + + # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h> + h2xs -n ONC::RPC rpcsvc/rusers + + # Without constant() or AUTOLOAD + h2xs -c rpcsvc/rusers + + # Creates templates for an extension named RPC + h2xs -cfn RPC + + # Extension is ONC::RPC. + h2xs -cfn ONC::RPC + + # Makefile.PL will look for library -lrpc in + # additional directory /opt/net/lib + h2xs rpcsvc/rusers -L/opt/net/lib -lrpc + + # Extension is DCE::rgynbase + # prefix "sec_rgy_" is dropped from perl function names + h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase + + # Extension is DCE::rgynbase + # prefix "sec_rgy_" is dropped from perl function names + # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid + h2xs -n DCE::rgynbase -p sec_rgy_ \ + -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase + + # Make XS without defines in perl.h, but with function declarations + # visible from perl.h. Name of the extension is perl1. + # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)= + # Extra backslashes below because the string is passed to shell. + # Note that a directory with perl header files would + # be added automatically to include path. + h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h + + # Same with function declaration in proto.h as visible from perl.h. + h2xs -xAn perl2 perl.h,proto.h + +=head1 ENVIRONMENT + +No environment variables are used. + +=head1 AUTHOR + +Larry Wall and others + +=head1 SEE ALSO + +L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>. + +=head1 DIAGNOSTICS + +The usual warnings if it cannot read or write the files involved. + +=cut + +my( $H2XS_VERSION ) = ' $Revision: 1.18 $ ' =~ /\$Revision:\s+([^\s]+)/; +my $TEMPLATE_VERSION = '0.01'; + +use Getopt::Std; + +sub usage{ + warn "@_\n" if @_; + die "h2xs [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]] +version: $H2XS_VERSION + -A Omit all autoloading facilities (implies -c). + -F Additional flags for C preprocessor (used with -x). + -O Allow overwriting of a pre-existing extension directory. + -P Omit the stub POD section. + -X Omit the XS portion. + -c Omit the constant() function and specialised AUTOLOAD from the XS file. + -d Turn on debugging messages. + -f Force creation of the extension even if the C header does not exist. + -h Display this help message + -n Specify a name to use for the extension (recommended). + -p Specify a prefix which should be removed from the Perl function names. + -s Create subroutines for specified macros. + -v Specify a version number for this extension. + -x Autogenerate XSUBs using C::Scan. +extra_libraries + are any libraries that might be needed for loading the + extension, e.g. -lm would try to link in the math library. +"; +} + + +getopts("AF:OPXcdfhn:p:s:v:x") || usage; + +usage if $opt_h; + +if( $opt_v ){ + $TEMPLATE_VERSION = $opt_v; +} +$opt_c = 1 if $opt_A; +%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; + +while (my $arg = shift) { + if ($arg =~ /^-l/i) { + $extralibs = "$arg @ARGV"; + last; + } + push(@path_h, $arg); +} + +usage "Must supply header file or module name\n" + unless (@path_h or $opt_n); + + +if( @path_h ){ + foreach my $path_h (@path_h) { + $name ||= $path_h; + if( $path_h =~ s#::#/#g && $opt_n ){ + warn "Nesting of headerfile ignored with -n\n"; + } + $path_h .= ".h" unless $path_h =~ /\.h$/; + $fullpath = $path_h; + $path_h =~ s/,.*$// if $opt_x; + if ($^O eq 'VMS') { # Consider overrides of default location + if ($path_h !~ m![:>\[]!) { + my($hadsys) = ($path_h =~ s!^sys/!!i); + if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; } + elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; } + elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' . + ($hadsys ? '[vms]' : '[000000]') . $path_h; } + elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; } + else { $path_h = "Sys\$Library:$path_h"; } + } + } + elsif ($^O eq 'os2') { + $path_h = "/usr/include/$path_h" + if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h"; + } + else { + $path_h = "/usr/include/$path_h" + if $path_h !~ m#^[./]# and -r "/usr/include/$path_h"; + } + + if (!$opt_c) { + die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h ); + # Scan the header file (we should deal with nested header files) + # Record the names of simple #define constants into const_names + # Function prototypes are processed below. + open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; + while (<CH>) { + if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) { + print "Matched $_ ($1)\n" if $opt_d; + $_ = $1; + next if /^_.*_h_*$/i; # special case, but for what? + if (defined $opt_p) { + if (!/^$opt_p(\d)/) { + ++$prefix{$_} if s/^$opt_p//; + } + else { + warn "can't remove $opt_p prefix from '$_'!\n"; + } + } + $const_names{$_}++; + } + } + close(CH); + } + } + @const_names = sort keys %const_names; +} + + +$module = $opt_n || do { + $name =~ s/\.h$//; + if( $name !~ /::/ ){ + $name =~ s#^.*/##; + $name = "\u$name"; + } + $name; +}; + +(chdir 'ext', $ext = 'ext/') if -d 'ext'; + +if( $module =~ /::/ ){ + $nested = 1; + @modparts = split(/::/,$module); + $modfname = $modparts[-1]; + $modpname = join('/',@modparts); +} +else { + $nested = 0; + @modparts = (); + $modfname = $modpname = $module; +} + + +if ($opt_O) { + warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; +} else { + die "Won't overwrite existing $ext$modpname\n" if -e $modpname; +} +if( $nested ){ + $modpath = ""; + foreach (@modparts){ + mkdir("$modpath$_", 0777); + $modpath .= "$_/"; + } +} +mkdir($modpname, 0777); +chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; + +my %types_seen; +my %std_types; +my $fdecls; +my $fdecls_parsed; + +if( ! $opt_X ){ # use XS, unless it was disabled + open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; + if ($opt_x) { + require C::Scan; # Run-time directive + require Config; # Run-time directive + warn "Scanning typemaps...\n"; + get_typemap(); + my $c; + my $filter; + my @fdecls; + foreach my $filename (@path_h) { + my $addflags = $opt_F || ''; + if ($fullpath =~ /,/) { + $filename = $`; + $filter = $'; + } + warn "Scanning $filename for functions...\n"; + $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, + 'add_cppflags' => $addflags; + $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); + + $fdecls_parsed = $c->get('parsed_fdecls'); + push(@fdecls, @{$c->get('fdecls')}); + } + $fdecls = [ @fdecls ]; + } +} + +open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; + +$" = "\n\t"; +warn "Writing $ext$modpname/$modfname.pm\n"; + +print PM <<"END"; +package $module; + +use strict; +END + +if( $opt_X || $opt_c || $opt_A ){ + # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD + print PM <<'END'; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); +END +} +else{ + # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and + # will want Carp. + print PM <<'END'; +use Carp; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); +END +} + +print PM <<'END'; + +require Exporter; +END + +print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled +require DynaLoader; +END + +# require autoloader if XS is disabled. +# if XS is enabled, require autoloader unless autoloading is disabled. +if( ($opt_X && (! $opt_A)) || (!$opt_X) ) { + print PM <<"END"; +require AutoLoader; +END +} + +if( $opt_X || ($opt_c && ! $opt_A) ){ + # we won't have our own AUTOLOAD(), so we'll inherit it. + if( ! $opt_X ) { # use DynaLoader, unless XS was disabled + print PM <<"END"; + +\@ISA = qw(Exporter AutoLoader DynaLoader); +END + } + else{ + print PM <<"END"; + +\@ISA = qw(Exporter AutoLoader); +END + } +} +else{ + # 1) we have our own AUTOLOAD(), so don't need to inherit it. + # or + # 2) we don't want autoloading mentioned. + if( ! $opt_X ){ # use DynaLoader, unless XS was disabled + print PM <<"END"; + +\@ISA = qw(Exporter DynaLoader); +END + } + else{ + print PM <<"END"; + +\@ISA = qw(Exporter); +END + } +} + +print PM<<"END"; +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +\@EXPORT = qw( + @const_names +); +\$VERSION = '$TEMPLATE_VERSION'; + +END + +print PM <<"END" unless $opt_c or $opt_X; +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my \$constname; + (\$constname = \$AUTOLOAD) =~ s/.*:://; + croak "&$module::constant not defined" if \$constname eq 'constant'; + my \$val = constant(\$constname, \@_ ? \$_[0] : 0); + if (\$! != 0) { + if (\$! =~ /Invalid/) { + \$AutoLoader::AUTOLOAD = \$AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + croak "Your vendor has not defined $module macro \$constname"; + } + } + *\$AUTOLOAD = sub () { \$val }; + goto &\$AUTOLOAD; +} + +END + +if( ! $opt_X ){ # print bootstrap, unless XS is disabled + print PM <<"END"; +bootstrap $module \$VERSION; +END +} + +if( $opt_P ){ # if POD is disabled + $after = '__END__'; +} +else { + $after = '=cut'; +} + +print PM <<"END"; + +# Preloaded methods go here. + +# Autoload methods go after $after, and are processed by the autosplit program. + +1; +__END__ +END + +$author = "A. U. Thor"; +$email = 'a.u.thor@a.galaxy.far.far.away'; + +my $const_doc = ''; +my $fdecl_doc = ''; +if (@const_names and not $opt_P) { + $const_doc = <<EOD; +\n=head1 Exported constants + + @{[join "\n ", @const_names]} + +EOD +} +if (defined $fdecls and @$fdecls and not $opt_P) { + $fdecl_doc = <<EOD; +\n=head1 Exported functions + + @{[join "\n ", @$fdecls]} + +EOD +} + +$pod = <<"END" unless $opt_P; +## Below is the stub of documentation for your module. You better edit it! +# +#=head1 NAME +# +#$module - Perl extension for blah blah blah +# +#=head1 SYNOPSIS +# +# use $module; +# blah blah blah +# +#=head1 DESCRIPTION +# +#Stub documentation for $module was created by h2xs. It looks like the +#author of the extension was negligent enough to leave the stub +#unedited. +# +#Blah blah blah. +#$const_doc$fdecl_doc +#=head1 AUTHOR +# +#$author, $email +# +#=head1 SEE ALSO +# +#perl(1). +# +#=cut +END + +$pod =~ s/^\#//gm unless $opt_P; +print PM $pod unless $opt_P; + +close PM; + + +if( ! $opt_X ){ # print XS, unless it is disabled +warn "Writing $ext$modpname/$modfname.xs\n"; + +print XS <<"END"; +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef __cplusplus +} +#endif + +END +if( @path_h ){ + foreach my $path_h (@path_h) { + my($h) = $path_h; + $h =~ s#^/usr/include/##; + if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } + print XS qq{#include <$h>\n}; + } + print XS "\n"; +} + +if( ! $opt_c ){ +print XS <<"END"; +static int +not_here(s) +char *s; +{ + croak("$module::%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { +END + +my(@AZ, @az, @under); + +foreach(@const_names){ + @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/; + @az = 'a' .. 'z' if !@az && /^[a-z]/; + @under = '_' if !@under && /^_/; +} + +foreach $letter (@AZ, @az, @under) { + + last if $letter eq 'a' && !@const_names; + + print XS " case '$letter':\n"; + my($name); + while (substr($const_names[0],0,1) eq $letter) { + $name = shift(@const_names); + $macro = $prefix{$name} ? "$opt_p$name" : $name; + next if $const_xsub{$macro}; + print XS <<"END"; + if (strEQ(name, "$name")) +#ifdef $macro + return $macro; +#else + goto not_there; +#endif +END + } + print XS <<"END"; + break; +END +} +print XS <<"END"; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +END +} + +$prefix = "PREFIX = $opt_p" if defined $opt_p; +# Now switch from C to XS by issuing the first MODULE declaration: +print XS <<"END"; + +MODULE = $module PACKAGE = $module $prefix + +END + +foreach (sort keys %const_xsub) { + print XS <<"END"; +char * +$_() + + CODE: +#ifdef $_ + RETVAL = $_; +#else + croak("Your vendor has not defined the $module macro $_"); +#endif + + OUTPUT: + RETVAL + +END +} + +# If a constant() function was written then output a corresponding +# XS declaration: +print XS <<"END" unless $opt_c; + +double +constant(name,arg) + char * name + int arg + +END + +my %seen_decl; + + +sub print_decl { + my $fh = shift; + my $decl = shift; + my ($type, $name, $args) = @$decl; + return if $seen_decl{$name}++; # Need to do the same for docs as well? + + my @argnames = map {$_->[1]} @$args; + my @argtypes = map { normalize_type( $_->[0] ) } @$args; + my @argarrays = map { $_->[4] || '' } @$args; + my $numargs = @$args; + if ($numargs and $argtypes[-1] eq '...') { + $numargs--; + $argnames[-1] = '...'; + } + local $" = ', '; + $type = normalize_type($type); + + print $fh <<"EOP"; + +$type +$name(@argnames) +EOP + + for $arg (0 .. $numargs - 1) { + print $fh <<"EOP"; + $argtypes[$arg] $argnames[$arg]$argarrays[$arg] +EOP + } +} + +# Should be called before any actual call to normalize_type(). +sub get_typemap { + # We do not want to read ./typemap by obvios reasons. + my @tm = qw(../../../typemap ../../typemap ../typemap); + my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; + unshift @tm, $stdtypemap; + my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; + my $image; + + foreach $typemap (@tm) { + next unless -e $typemap ; + # skip directories, binary files etc. + warn " Scanning $typemap\n"; + warn("Warning: ignoring non-text typemap file '$typemap'\n"), next + unless -T $typemap ; + open(TYPEMAP, $typemap) + or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; + my $mode = 'Typemap'; + while (<TYPEMAP>) { + next if /^\s*\#/; + if (/^INPUT\s*$/) { $mode = 'Input'; next; } + elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; } + elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } + elsif ($mode eq 'Typemap') { + next if /^\s*($|\#)/ ; + if ( ($type, $image) = + /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o + # This may reference undefined functions: + and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) { + normalize_type($type); + } + } + } + close(TYPEMAP) or die "Cannot close $typemap: $!"; + } + %std_types = %types_seen; + %types_seen = (); +} + + +sub normalize_type { + my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*'; + my $type = shift; + $type =~ s/$ignore_mods//go; + $type =~ s/([\]\[()])/ \1 /g; + $type =~ s/\s+/ /g; + $type =~ s/\s+$//; + $type =~ s/^\s+//; + $type =~ s/\b\*/ */g; + $type =~ s/\*\b/* /g; + $type =~ s/\*\s+(?=\*)/*/g; + $types_seen{$type}++ + unless $type eq '...' or $type eq 'void' or $std_types{$type}; + $type; +} + +if ($opt_x) { + for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } +} + +close XS; + +if (%types_seen) { + my $type; + warn "Writing $ext$modpname/typemap\n"; + open TM, ">typemap" or die "Cannot open typemap file for write: $!"; + + for $type (keys %types_seen) { + print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n" + } + + close TM or die "Cannot close typemap file for write: $!"; +} + +} # if( ! $opt_X ) + +warn "Writing $ext$modpname/Makefile.PL\n"; +open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; + +print PL <<'END'; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +END +print PL "WriteMakefile(\n"; +print PL " 'NAME' => '$module',\n"; +print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n"; +if( ! $opt_X ){ # print C stuff, unless XS is disabled + print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n"; + print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n"; + print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; +} +print PL ");\n"; +close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; + +warn "Writing $ext$modpname/test.pl\n"; +open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n"; +print EX <<'_END_'; +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..1\n"; } +END {print "not ok 1\n" unless $loaded;} +_END_ +print EX <<_END_; +use $module; +_END_ +print EX <<'_END_'; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +_END_ +close(EX) || die "Can't close $ext$modpname/test.pl: $!\n"; + +warn "Writing $ext$modpname/Changes\n"; +open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; +print EX "Revision history for Perl extension $module.\n\n"; +print EX "$TEMPLATE_VERSION ",scalar localtime,"\n"; +print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n"; +close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; + +warn "Writing $ext$modpname/MANIFEST\n"; +open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!"; +@files = <*>; +if (!@files) { + eval {opendir(D,'.');}; + unless ($@) { @files = readdir(D); closedir(D); } +} +if (!@files) { @files = map {chomp && $_} `ls`; } +if ($^O eq 'VMS') { + foreach (@files) { + # Clip trailing '.' for portability -- non-VMS OSs don't expect it + s%\.$%%; + # Fix up for case-sensitive file systems + s/$modfname/$modfname/i && next; + $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes'; + $_ = 'Makefile.PL' if $_ eq 'makefile.pl'; + } +} +print MANI join("\n",@files), "\n"; +close MANI; +!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 ':'; +chdir $origdir; diff --git a/contrib/perl5/utils/perlbug.PL b/contrib/perl5/utils/perlbug.PL new file mode 100644 index 0000000..589e7e6 --- /dev/null +++ b/contrib/perl5/utils/perlbug.PL @@ -0,0 +1,1093 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# 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}. +# $perlpath + +# 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. +$origdir = cwd; +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT, ">$file" or die "Can't create $file: $!"; + +# extract patchlevel.h information + +open PATCH_LEVEL, "<../patchlevel.h" or die "Can't open patchlevel.h: $!"; + +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>) { + last if /^\s*}/; + chomp; + s/^\s+,?"?//; + s/"?,?$//; + s/(['\\])/\\$1/g; + push @patches, $_ unless $_ eq 'NULL'; +} +my $patch_desc = "'" . join("',\n '", @patches) . "'"; +my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; + +close PATCH_LEVEL; + +# TO DO (prehaps): store/embed $Config::config_sh into perlbug. When perlbug is +# used, compare $Config::config_sh with the stored version. If they differ then +# append a list of individual differences to the bug report. + + +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; + +my \$config_tag1 = '$] - $Config{cf_time}'; + +my \$patchlevel_date = $patchlevel_date; +my \$patch_tags = '$patch_tags'; +my \@patches = ( + $patch_desc +); +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +use Config; +use Getopt::Std; +use strict; + +sub paraprint; + +BEGIN { + eval "use Mail::Send;"; + $::HaveSend = ($@ eq ""); + eval "use Mail::Util;"; + $::HaveUtil = ($@ eq ""); +}; + +my $Version = "1.26"; + +# 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. +# Changed in 1.08 to use correct address for sendmail. +# Changed in 1.09 to close the REP file before calling it up in the editor. +# Also removed some old comments duplicated elsewhere. +# Changed in 1.10 to run under VMS without Mail::Send; also fixed +# temp filename generation. +# Changed in 1.11 to clean up some text and removed Mail::Send deactivator. +# Changed in 1.12 to check for editor errors, make save/send distinction +# clearer and add $ENV{REPLYTO}. +# Changed in 1.13 to hopefully make it more difficult to accidentally +# send mail +# Changed in 1.14 to make the prompts a little more clear on providing +# helpful information. Also let file read fail gracefully. +# Changed in 1.15 to add warnings to stop people using perlbug for non-bugs. +# Also report selected environment variables. +# Changed in 1.16 to include @INC, and allow user to re-edit if no changes. +# Changed in 1.17 Win32 support added. GSAR 97-04-12 +# Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18 +# Changed in 1.19 '-ok' default not '-v' +# 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 +# Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt +# Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01 +# Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12 +# Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15 + +# TODO: - Allow the user to re-name the file on mail failure, and +# 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, $outfile, + $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 && !($ok and not $::opt_n)) { + paraprint <<EOF; +Please use perlbug interactively. If you want to +include a file, you can use the -f switch. +EOF + die "\n"; +} +if (!-t STDOUT && !$outfile) { Dump(*STDOUT); exit; } + +Query(); +Edit() unless $usefile || ($ok and not $::opt_n); +NowWhat(); +Send(); + +exit; + +sub Init { + # -------- Setup -------- + + $Is_MSWin32 = $^O eq 'MSWin32'; + $Is_VMS = $^O eq 'VMS'; + + if (!getopts("dhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; }; + + # 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 || ""; + + # File to output to + $outfile = $::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 + 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 + + $from = $::Config{'cf_email'} + if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me && + ($me eq $::Config{'cf_by'}); +} # sub Init + +sub Query { + # 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 +sending test messages or simply verifying that perl works, *NOR* is it +intended for reporting bugs in third-party perl modules. It is *ONLY* +a means of reporting verifiable problems with the core perl distribution, +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 + 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 = <>; + + my $err = 0; + while ($subject !~ /\S/) { + print "\nPlease enter a subject: "; + $subject = <>; + if ($err++ > 5) { + die "Aborting.\n"; + } + } + 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 { + $guess = "$me\@$domain" if $domain; + } + } + } + + 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 +your full internet e-mail address here. +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 +correct it, or enter 'none' or 'yourself' to not send +a copy. +EOF + print "Local perl administrator [$cc]: "; + my $entry = scalar <>; + chop $entry; + + if ($entry ne "") { + $cc = $entry; + $cc = '' if $me eq $cc; + } + } + + $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i; + $andcc = " and $cc" if $cc; + + # Prompt for editor, if no override is given +editor: + 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 +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 +result, and what you expected. + +Some information about your local +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. + +You will probably want to use an editor to enter +the report. If "$ed" is the editor you want +to use, then just press Enter, otherwise type in +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; + } + } + + # Generate scratch file to edit report in + $filename = filename(); + + # Prompt for file to read report from, if needed + if ($usefile and !$file) { +filename: + paraprint <<EOF; +What is the name of the file that contains your report? +EOF + 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. +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; + } + + # Generate report + open(REP,">$filename"); + my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success"; + + 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; + +----------------------------------------------------------------- +[Please enter your report here] + + + +[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); +} # sub Query + +sub Dump { + local(*OUT) = @_; + + 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; +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 (@patches) { + print OUT join "\n ", "Locally applied patches:", @patches; + print OUT "\n"; + }; + + print OUT <<EOF; + +--- +\@INC for perl $]: +EOF + for my $i (@INC) { + print OUT " $i\n"; + } + + 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"; + } + } +} # sub Dump + +sub Edit { + # 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; + $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. +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 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(); + } + } +} # sub Edit + +sub Cancel { + 1 while unlink($filename); # remove all versions under VMS + print "\nCancelling.\n"; + exit(0); +} + +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 +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 + retry: + 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 ""; + + unless (open(FILE, ">$file")) { + print "\nError opening $file: $!\n\n"; + goto retry; + } + 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(); + } 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 ($outfile) { + open SENDMAIL, ">$outfile" or die "Couldn't open '$outfile': $!\n"; + goto sendout; + } + 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"; + } + } + + 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: $!"; +sendout: + 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)) { + printf "\nMessage %s.\n", $outfile ? "saved" : "sent"; + } else { + warn "\nSendmail returned status '", $? >> 8, "'\n"; + } + } + 1 while unlink($filename); # remove all versions under VMS +} # sub Send + +sub Help { + print <<EOF; + +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 inpufile ] [ -F outputfile ] + [-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 + quickly send a prepared message. + -F File to output the resulting mail message to, instead of mailing. + -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 + 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. + -t Test mode. The target address defaults to `$testaddress'. + -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, use -nok. + -okay As -ok but allow report from old builds. + -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"; + } +} + +format STDOUT = +^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ +$_ +. + +__END__ + +=head1 NAME + +perlbug - how to submit bug reports on Perl + +=head1 SYNOPSIS + +B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]> +S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]> +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<-nok> | B<-nokay> ]> + +=head1 DESCRIPTION + +A program to help generate bug reports about perl or the modules that +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 +non-standard module (such as Tk, CGI, etc), then please see the +documentation that came with that distribution to determine the correct +place to report bugs. + +C<perlbug> is designed to be used interactively. Normally no arguments +will be needed. Simply run it, and follow the prompts. + +If you are unable to run B<perlbug> (most likely because you don't have +a working setup to send mail that perlbug recognizes), you may have to +compose your own report, and email it to B<perlbug@perl.com>. You might +find the B<-d> option useful to get summary information in that case. + +In any case, when reporting a bug, please make sure you have run through +this checklist: + +=over 4 + +=item What version of perl you are running? + +Type C<perl -v> at the command line to find out. + +=item Are you running the latest released version of perl? + +Look at http://www.perl.com/ to find out. If it is not the latest +released version, get that one and see whether your bug has been +fixed. Note that bug reports about old versions of perl, especially +those prior to the 5.0 release, are likely to fall upon deaf ears. +You are on your own if you continue to use perl1 .. perl4. + +=item Are you sure what you have is a bug? + +A significant number of the bug reports we get turn out to be documented +features in perl. Make sure the behavior you are witnessing doesn't fall +under that category, by glancing through the documentation that comes +with perl (we'll admit this is no mean task, given the sheer volume of +it all, but at least have a look at the sections that I<seem> relevant). + +Be aware of the familiar traps that perl programmers of various hues +fall into. See L<perltrap>. + +Try to study the problem under the perl debugger, if necessary. +See L<perldebug>. + +=item Do you have a proper test case? + +The easier it is to reproduce your bug, the more likely it will be +fixed, because if no one can duplicate the problem, no one can fix it. +A good test case has most of these attributes: fewest possible number +of lines; few dependencies on external commands, modules, or +libraries; runs on most platforms unimpeded; and is self-documenting. + +A good test case is almost always a good candidate to be on the perl +test suite. If you have the time, consider making your test case so +that it will readily fit into the standard test suite. + +=item Can you describe the bug in plain English? + +The easier it is to understand a reproducible bug, the more likely it +will be fixed. Anything you can provide by way of insight into the +problem helps a great deal. In other words, try to analyse the +problem to the extent you feel qualified and report your discoveries. + +=item Can you fix the bug yourself? + +A bug report which I<includes a patch to fix it> will almost +definitely be fixed. Use the C<diff> program to generate your patches +(C<diff> is being maintained by the GNU folks as part of the B<diffutils> +package, so you should be able to get it from any of the GNU software +repositories). If you do submit a patch, the cool-dude counter at +perlbug@perl.com will register you as a savior of the world. Your +patch may be returned with requests for changes, or requests for more +detailed explanations about your fix. + +Here are some clues for creating quality patches: Use the B<-c> or +B<-u> switches to the diff program (to create a so-called context or +unified diff). Make sure the patch is not reversed (the first +argument to diff is typically the original file, the second argument +your changed file). Make sure you test your patch by applying it with +the C<patch> program before you send it on its way. Try to follow the +same style as the code you are trying to patch. Make sure your patch +really does work (C<make test>, if the thing you're patching supports +it). + +=item Can you use C<perlbug> to submit the report? + +B<perlbug> will, amongst other things, ensure your report includes +crucial information about your version of perl. If C<perlbug> is unable +to mail your report after you have typed it in, you may have to compose +the message yourself, add the output produced by C<perlbug -d> and email +it to B<perlbug@perl.com>. If, for some reason, you cannot run +C<perlbug> at all on your system, be sure to include the entire output +produced by running C<perl -V> (note the uppercase V). + +=back + +Having done your bit, please be prepared to wait, to be told the bug +is in your code, or even to get no reply at all. The perl maintainers +are busy folks, so if your problem is a small one or if it is difficult +to understand or already known, they may not respond with a personal reply. +If it is important to you that your bug be fixed, do monitor the +C<Changes> file in any development releases since the time you submitted +the bug, and encourage the maintainers with kind words (but never any +flames!). Feel free to resend your bug report if the next released +version of perl comes out and your bug is still present. + +=head1 OPTIONS + +=over 8 + +=item B<-a> + +Address to send the report to. Defaults to `perlbug@perl.com'. + +=item B<-b> + +Body of the report. If not included on the command line, or +in a file with B<-f>, you will get a chance to edit the message. + +=item B<-C> + +Don't send copy to administrator. + +=item B<-c> + +Address to send copy of report to. Defaults to the address of the +local perl administrator (recorded when perl was built). + +=item B<-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 B<-v> to get more complete data. + +=item B<-e> + +Editor to use. + +=item B<-f> + +File containing the body of the report. Use this to quickly send a +prepared message. + +=item B<-F> + +File to output the results to instead of sending as an email. Useful +particularly when running perlbug on a machine with no direct internet +connection. + +=item B<-h> + +Prints a brief summary of the options. + +=item B<-ok> + +Report successful build on this system to perl porters. Forces B<-S> +and B<-C>. Forces and supplies values for B<-s> and B<-b>. 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<-okay> + +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 +if you don't use this option. + +=item B<-S> + +Send without asking for confirmation. + +=item B<-s> + +Subject to include with the message. You will be prompted if you don't +supply one on the command line. + +=item B<-t> + +Test mode. The target address defaults to `perlbug-test@perl.com'. + +=item B<-v> + +Include verbose configuration data in the report. + +=back + +=head1 AUTHORS + +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>), 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 + +perl(1), perldebug(1), perltrap(1), diff(1), patch(1) + +=head1 BUGS + +None known (guess what must have been used to report them?) + +=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 ':'; +chdir $origdir; + diff --git a/contrib/perl5/utils/perlcc.PL b/contrib/perl5/utils/perlcc.PL new file mode 100644 index 0000000..b214645 --- /dev/null +++ b/contrib/perl5/utils/perlcc.PL @@ -0,0 +1,945 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# 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. +$origdir = cwd; +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 Cwd; + +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.$Config{so}"; + $type = 'sharedlib'; + return() if (!$obj); + $objfile = ($options->{'C'}) ? $options->{'C'} : "$file.c"; + } + 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'}); + $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($so) 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('static', $sourceprog, "-o", $output_executable, $generated_cfile); + $return[0]; + } + else + { + my $object_file = $generated_cfile; + $object_file =~ s"\.c$"$Config{_o}"; + + $return[0] = _ccharness('compile', $sourceprog, "-c", $generated_cfile); + $return[1] = _ccharness + ( + 'dynamic', + $sourceprog, "-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 $type = shift; + 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.. -L."; + $incdir = "-I.. -I."; + } + + $libdir .= " -L$options->{L}" if (defined($options->{L})); + $incdir .= " -I$options->{L}" if (defined($options->{L})); + + my $linkargs = ''; + + if (!grep(/^-[cS]$/, @args)) + { + my $lperl = $^O eq 'os2' ? '-llibperl' : '-lperl'; + my $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags}; + $linkargs = "$flags $libdir $lperl @Config{libs}"; + } + + my @sharedobjects = _getSharedObjects($sourceprog); + + my $cccmd = + "$Config{cc} @Config{qw(ccflags optimize)} $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 ); + + $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\x00\\.:g, @$regexp); + grep(s:(^|[^\x00])\\\.:$1\.:g, @$regexp); + grep(s:\x00::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 ':'; +chdir $origdir; diff --git a/contrib/perl5/utils/perldoc.PL b/contrib/perl5/utils/perldoc.PL new file mode 100644 index 0000000..875cd25 --- /dev/null +++ b/contrib/perl5/utils/perldoc.PL @@ -0,0 +1,687 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# 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}. + +# 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. +$origdir = cwd; +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 0; + +use strict; +my \@pagers = (); +push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}"; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +# +# Perldoc revision #1 -- look up a piece of documentation in .pod format that +# is embedded in the perl installation tree. +# +# This is not to be confused with Tom Christianson's perlman, which is a +# man replacement, written in perl. This perldoc is strictly for reading +# the perl manuals, though it too is written in perl. + +if(@ARGV<1) { + my $me = $0; # Editing $0 is unportable + $me =~ s,.*/,,; + 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. +EOF +} + +use Getopt::Std; +use Config '%Config'; + +my @global_found = (); +my $global_target = ""; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $Is_Dos = $^O eq 'dos'; + +sub usage{ + warn "@_\n" if @_; + # Erase evidence of previous errors (if any), so exit status is simple. + $! = 0; + die <<EOF; +perldoc [options] PageName|ModuleName|ProgramName... +perldoc [options] -f BuiltinFunction +perldoc [options] -q FAQRegex + +Options: + -h Display this help message + -r Recursive search (slow) + -i Ignore case + -t Display pod using pod2text instead of pod2man and nroff + (-t is the default on win32) + -u Display unformatted pod text + -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 + `perlfunc') the name of a module, either like `Term::Info', + `Term/Info', the partial name of a module, like `info', or + `makemaker', or the name of a program, like `perldoc'. + +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. + +EOF +} + +if( defined $ENV{"PERLDOC"} ) { + require Text::ParseWords; + unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"})); +} +!NO!SUBS! + +my $getopts = "mhtluvriFf:Xq:"; +print OUT <<"!GET!OPTS!"; + +use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} ); + +getopts("$getopts") || usage; +!GET!OPTS! + +print OUT <<'!NO!SUBS!'; + +usage if $opt_h; + +my $podidx; +if( $opt_X ) { + $podidx = "$Config{'archlib'}/pod.idx"; + $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; +} + +if( (my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { + usage("only one of -t, -u, -m or -l") +} elsif ($Is_MSWin32 || $Is_Dos) { + $opt_t = 1 unless $opts +} + +if ($opt_t) { require Pod::Text; import Pod::Text; } + +my @pages; +if ($opt_f) { + @pages = ("perlfunc"); +} elsif ($opt_q) { + @pages = ("perlfaq1" .. "perlfaq9"); +} else { + @pages = @ARGV; +} + +# Does this look like a module or extension directory? +if (-f "Makefile.PL") { + # Add ., lib and blib/* libs to @INC (if they exist) + unshift(@INC, '.'); + unshift(@INC, 'lib') if -d 'lib'; + require ExtUtils::testlib; +} + + + +sub containspod { + my($file, $readit) = @_; + return 1 if !$readit && $file =~ /\.pod$/i; + local($_); + open(TEST,"<$file"); + while(<TEST>) { + if(/^=head/) { + close(TEST); + return 1; + } + } + close(TEST); + return 0; +} + +sub minus_f_nocase { + my($dir,$file) = @_; + my $path = join('/',$dir,$file); + return $path if -f $path and -r _; + if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { + # on a case-forgiving file system or if case is important + # that is it all we can do + warn "Ignored $file: unreadable\n" if -f _; + return ''; + } + local *DIR; + local($")="/"; + my @p = ($dir); + my($p,$cip); + foreach $p (split(/\//, $file)){ + my $try = "@p/$p"; + stat $try; + if (-d _){ + push @p, $p; + if ( $p eq $global_target) { + my $tmp_path = join ('/', @p); + my $path_f = 0; + for (@global_found) { + $path_f = 1 if $_ eq $tmp_path; + } + push (@global_found, $tmp_path) unless $path_f; + print STDERR "Found as @p but directory\n" if $opt_v; + } + } elsif (-f _ && -r _) { + return $try; + } elsif (-f _) { + warn "Ignored $try: unreadable\n"; + } else { + my $found=0; + my $lcp = lc $p; + opendir DIR, "@p"; + while ($cip=readdir(DIR)) { + if (lc $cip eq $lcp){ + $found++; + last; + } + } + closedir DIR; + return "" unless $found; + push @p, $cip; + return "@p" if -f "@p" and -r _; + warn "Ignored $file: unreadable\n" if -f _; + } + } + return ""; +} + + +sub check_file { + my($dir,$file) = @_; + if ($opt_m) { + return minus_f_nocase($dir,$file); + } else { + my $path = minus_f_nocase($dir,$file); + return $path if length $path and containspod($path); + } + return ""; +} + + +sub searchfor { + my($recurse,$s,@dirs) = @_; + $s =~ s!::!/!g; + $s = VMS::Filespec::unixify($s) if $Is_VMS; + return $s if -f $s && containspod($s); + printf STDERR "Looking for $s in @dirs\n" if $opt_v; + my $ret; + my $i; + my $dir; + $global_target = (split('/', $s))[-1]; + for ($i=0; $i<@dirs; $i++) { + $dir = $dirs[$i]; + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS; + if ( ( $ret = check_file $dir,"$s.pod") + or ( $ret = check_file $dir,"$s.pm") + or ( $ret = check_file $dir,$s) + or ( $Is_VMS and + $ret = check_file $dir,"$s.com") + or ( $^O eq 'os2' and + $ret = check_file $dir,"$s.cmd") + or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and + $ret = check_file $dir,"$s.bat") + or ( $ret = check_file "$dir/pod","$s.pod") + or ( $ret = check_file "$dir/pod",$s) + ) { + return $ret; + } + + if ($recurse) { + opendir(D,$dir); + my @newdirs = map "$dir/$_", grep { + not /^\.\.?$/ and + not /^auto$/ and # save time! don't search auto dirs + -d "$dir/$_" + } readdir D; + closedir(D); + next unless @newdirs; + @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS; + print STDERR "Also looking in @newdirs\n" if $opt_v; + push(@dirs,@newdirs); + } + } + return (); +} + +my @found; +foreach (@pages) { + if ($podidx && open(PODIDX, $podidx)) { + my $searchfor = $_; + local($_); + $searchfor =~ s,::,/,g; + print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; + while (<PODIDX>) { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; + } + close(PODIDX); + next; + } + print STDERR "Searching for $_\n" if $opt_v; + # We must look both in @INC for library modules and in PATH + # for executables, like h2xs or perldoc itself. + my @searchdirs = @INC; + if ($opt_F) { + next unless -r; + push @found, $_ if $opt_m or containspod($_); + next; + } + unless ($opt_m) { + if ($Is_VMS) { + my($i,$trn); + for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) { + push(@searchdirs,$trn); + } + push(@searchdirs,'perl_root:[lib.pod]') # installed pods + } else { + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); + } + } + my @files = searchfor(0,$_,@searchdirs); + if( @files ) { + print STDERR "Found as @files\n" if $opt_v; + } else { + # no match, try recursive search + + @searchdirs = grep(!/^\.$/,@INC); + + @files= searchfor(1,$_,@searchdirs) if $opt_r; + if( @files ) { + print STDERR "Loosely found as @files\n" if $opt_v; + } else { + print STDERR "No documentation found for \"$_\".\n"; + if (@global_found) { + print STDERR "However, try\n"; + for my $dir (@global_found) { + opendir(DIR, $dir) or die "$!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./); + $file =~ s/\.(pm|pod)$//; + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR; + } + } + } + } + push(@found,@files); +} + +if(!@found) { + exit ($Is_VMS ? 98962 : 1); +} + +if ($opt_l) { + print join("\n", @found), "\n"; + exit; +} + +my $lines = $ENV{LINES} || 24; + +my $no_tty; +if( ! -t STDOUT ) { $no_tty = 1 } + +my $tmp; +if ($Is_MSWin32) { + $tmp = "$ENV{TEMP}\\perldoc1.$$"; + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; +} elsif ($Is_VMS) { + $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; + push @pagers, qw( most more less type/page ); +} elsif ($Is_Dos) { + $tmp = "$ENV{TEMP}/perldoc1.$$"; + $tmp =~ tr!\\/!//!s; + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; +} else { + if ($^O eq 'os2') { + require POSIX; + $tmp = POSIX::tmpnam(); + unshift @pagers, 'less', 'cmd /c more <'; + } else { + $tmp = "/tmp/perldoc1.$$"; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; +} +unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; + +if ($opt_m) { + foreach my $pager (@pagers) { + system("$pager @found") or exit; + } + if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } + exit 1; +} + +if ($opt_f) { + my $perlfunc = shift @found; + open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!"; + + # Skip introduction + while (<PFUNC>) { + last if /^=head2 Alphabetical Listing of Perl Functions/; + } + + # Look for our function + my $found = 0; + my @pod; + while (<PFUNC>) { + if (/^=item\s+\Q$opt_f\E\b/o) { + $found = 1; + } elsif (/^=item/) { + last if $found > 1; + } + next unless $found; + push @pod, $_; + ++$found if /^\w/; # found descriptive text + } + 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); + } elsif (@pod < $lines-2) { + print @pod; + } else { + foreach my $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"; + } + 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); + } elsif (@pod < $lines-2) { + print @pod; + } else { + foreach my $pager (@pagers) { + open (PAGER, "| $pager") or next; + print PAGER @pod ; + close(PAGER) or next; + last; + } + } + } else { + die "No documentation for perl FAQ keyword `$opt_q' found\n"; + } + exit; +} + +foreach (@found) { + + my $err; + if($opt_t) { + open(TMP,">>$tmp"); + Pod::Text::pod2text($_,*TMP); + close(TMP); + } elsif(not $opt_u) { + my $cmd = "pod2man --lax $_ | nroff -man"; + $cmd .= " | col -x" if $^O =~ /hpux/; + my $rslt = `$cmd`; + unless(($err = $?)) { + open(TMP,">>$tmp"); + print TMP $rslt; + close TMP; + } + } + + if( $opt_u or $err or -z $tmp) { + open(OUT,">>$tmp"); + open(IN,"<$_"); + my $cut = 1; + while (<IN>) { + $cut = $1 eq 'cut' if /^=(\w+)/; + next if $cut; + print OUT; + } + close(IN); + close(OUT); + } +} + +if( $no_tty ) { + open(TMP,"<$tmp"); + print while <TMP>; + close(TMP); +} else { + foreach my $pager (@pagers) { + system("$pager $tmp") or last; + } +} + +1 while unlink($tmp); #Possibly pointless VMSism + +exit 0; + +__END__ + +=head1 NAME + +perldoc - Look up Perl documentation in pod format. + +=head1 SYNOPSIS + +B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName + +B<perldoc> B<-f> BuiltinFunction + +B<perldoc> B<-q> FAQ Keyword + +=head1 DESCRIPTION + +I<perldoc> looks up a piece of documentation in .pod format that is embedded +in the perl installation tree or in a perl script, and displays it via +C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX, +C<col -x> will be used.) This is primarily used for the documentation for +the perl library modules. + +Your system may also have man pages installed for those modules, in +which case you can probably just use the man(1) command. + +=head1 OPTIONS + +=over 5 + +=item B<-h> help + +Prints out a brief help message. + +=item B<-v> verbose + +Describes search for the item in detail. + +=item B<-t> text output + +Display docs using plain text converter, instead of nroff. This may be faster, +but it won't look as nice. + +=item B<-u> unformatted + +Find docs only; skip reformatting by pod2* + +=item B<-m> module + +Display the entire module: both code and unformatted pod documentation. +This may be useful if the docs don't explain a function in the detail +you need, and you'd like to inspect the code directly; perldoc will find +the file for you and simply hand it off for display. + +=item B<-l> file name only + +Display the file name of the module found. + +=item B<-F> file names + +Consider arguments as file names, no search in directories will be performed. + +=item B<-f> perlfunc + +The B<-f> option followed by the name of a perl built in function will +extract the documentation of this function from L<perlfunc>. + +=item B<-q> perlfaq + +The B<-q> option takes a regular expression as an argument. It will search +the question headings in perlfaq[1-9] and print the entries matching +the regular expression. + +=item B<-X> use an index if present + +The B<-X> option looks for a entry whose basename matches the name given on the +command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should +contain fully qualified filenames, one per line. + +=item B<PageName|ModuleName|ProgramName> + +The item you want to look up. Nested modules (such as C<File::Basename>) +are specified either as C<File::Basename> or C<File/Basename>. You may also +give a descriptive name of a page, such as C<perlfunc>. You make also give a +partial or wrong-case name, such as "basename" for "File::Basename", but +this will be slower, if there is more then one page with the same partial +name, you will only get the first one. + +=back + +=head1 ENVIRONMENT + +Any switches in the C<PERLDOC> environment variable will be used before the +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> 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 + +Kenneth Albanowski <kjahds@kjahds.com> + +Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu> + +=cut + +# +# Version 1.14: Wed Jul 15 01:50:20 EST 1998 +# Robin Barker <rmb1@cise.npl.co.uk> +# -strict, -w cleanups +# Version 1.13: Fri Feb 27 16:20:50 EST 1997 +# Gurusamy Sarathy <gsar@umich.edu> +# -doc tweaks for -F and -X options +# Version 1.12: Sat Apr 12 22:41:09 EST 1997 +# Gurusamy Sarathy <gsar@umich.edu> +# -various fixes for win32 +# Version 1.11: Tue Dec 26 09:54:33 EST 1995 +# Kenneth Albanowski <kjahds@kjahds.com> +# -added Charles Bailey's further VMS patches, and -u switch +# -added -t switch, with pod2text support +# +# Version 1.10: Thu Nov 9 07:23:47 EST 1995 +# Kenneth Albanowski <kjahds@kjahds.com> +# -added VMS support +# -added better error recognition (on no found pages, just exit. On +# missing nroff/pod2man, just display raw pod.) +# -added recursive/case-insensitive matching (thanks, Andreas). This +# slows things down a bit, unfortunately. Give a precise name, and +# it'll run faster. +# +# Version 1.01: Tue May 30 14:47:34 EDT 1995 +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# -added pod documentation. +# -added PATH searching. +# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod +# and friends. +# +# +# TODO: +# +# Cache directories read during sloppy match +!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 ':'; +chdir $origdir; diff --git a/contrib/perl5/utils/pl2pm.PL b/contrib/perl5/utils/pl2pm.PL new file mode 100644 index 0000000..48e281d --- /dev/null +++ b/contrib/perl5/utils/pl2pm.PL @@ -0,0 +1,389 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# 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}. + +# 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. +$origdir = cwd; +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!'; + +=head1 NAME + +pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules. + +=head1 SYNOPSIS + +B<pl2pm> F<files> + +=head1 DESCRIPTION + +B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl +library files to Perl5-style library modules. Usually, your old .pl +file will still work fine and you should only use this tool if you +plan to update your library to use some of the newer Perl 5 features, +such as AutoLoading. + +=head1 LIMITATIONS + +It's just a first step, but it's usually a good first step. + +=head1 AUTHOR + +Larry Wall <larry@wall.org> + +=cut + +while (<DATA>) { + chop; + $keyword{$_} = 1; +} + +undef $/; +$* = 1; +while (<>) { + $newname = $ARGV; + $newname =~ s/\.pl$/.pm/ || next; + $newname =~ s#(.*/)?(\w+)#$1\u$2#; + if (-f $newname) { + warn "Won't overwrite existing $newname\n"; + next; + } + $oldpack = $2; + $newpack = "\u$2"; + @export = (); + print "$oldpack => $newpack\n" if $verbose; + + s/\bstd(in|out|err)\b/\U$&/g; + s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig; + if (/sub\s+main'/) { + @export = m/sub\s+main'(\w+)/g; + s/(sub\s+)main'(\w+)/$1$2/g; + } + else { + @export = m/sub\s+([A-Za-z]\w*)/g; + } + @export_ok = grep($keyword{$_}, @export); + @export = grep(!$keyword{$_}, @export); + @export{@export} = (1) x @export; + s/(^\s*);#/$1#/g; + s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/; + s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig; + s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg; + s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg; + if (!/\$\[\s*\)?\s*=\s*[^0\s]/) { + s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g; + s/\$\[\s*\+\s*//g; + s/\s*\+\s*\$\[//g; + s/\$\[/0/g; + } + s/open\s+(\w+)/open($1)/g; + + if (s/\bdie\b/croak/g) { + $carp = "use Carp;\n"; + s/croak "([^"]*)\\n"/croak "$1"/g; + } + else { + $carp = ""; + } + if (@export_ok) { + $export_ok = "\@EXPORT_OK = qw(@export_ok);\n"; + } + else { + $export_ok = ""; + } + + open(PM, ">$newname") || warn "Can't create $newname: $!\n"; + print PM <<"END"; +package $newpack; +require 5.000; +require Exporter; +$carp +\@ISA = qw(Exporter); +\@EXPORT = qw(@export); +$export_ok +$_ +END +} + +sub xlate { + local($prefix, $pack, $ident) = @_; + if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) { + "${pack}'$ident"; + } + elsif ($pack eq "" || $pack eq "main") { + if ($export{$ident}) { + "$prefix$ident"; + } + else { + "$prefix${pack}::$ident"; + } + } + elsif ($pack eq $oldpack) { + "$prefix${newpack}::$ident"; + } + else { + "$prefix${pack}::$ident"; + } +} +__END__ +AUTOLOAD +BEGIN +CORE +DESTROY +END +abs +accept +alarm +and +atan2 +bind +binmode +bless +caller +chdir +chmod +chop +chown +chr +chroot +close +closedir +cmp +connect +continue +cos +crypt +dbmclose +dbmopen +defined +delete +die +do +dump +each +else +elsif +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +eof +eq +eval +exec +exit +exp +fcntl +fileno +flock +for +foreach +fork +format +formline +ge +getc +getgrent +getgrgid +getgrnam +gethostbyaddr +gethostbyname +gethostent +getlogin +getnetbyaddr +getnetbyname +getnetent +getpeername +getpgrp +getppid +getpriority +getprotobyname +getprotobynumber +getprotoent +getpwent +getpwnam +getpwuid +getservbyname +getservbyport +getservent +getsockname +getsockopt +glob +gmtime +goto +grep +gt +hex +if +index +int +ioctl +join +keys +kill +last +lc +lcfirst +le +length +link +listen +local +localtime +log +lstat +lt +m +mkdir +msgctl +msgget +msgrcv +msgsnd +my +ne +next +no +not +oct +open +opendir +or +ord +pack +package +pipe +pop +print +printf +push +q +qq +quotemeta +qw +qx +rand +read +readdir +readline +readlink +readpipe +recv +redo +ref +rename +require +reset +return +reverse +rewinddir +rindex +rmdir +s +scalar +seek +seekdir +select +semctl +semget +semop +send +setgrent +sethostent +setnetent +setpgrp +setpriority +setprotoent +setpwent +setservent +setsockopt +shift +shmctl +shmget +shmread +shmwrite +shutdown +sin +sleep +socket +socketpair +sort +splice +split +sprintf +sqrt +srand +stat +study +sub +substr +symlink +syscall +sysread +system +syswrite +tell +telldir +tie +time +times +tr +truncate +uc +ucfirst +umask +undef +unless +unlink +unpack +unshift +untie +until +use +utime +values +vec +wait +waitpid +wantarray +warn +while +write +x +xor +y +!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 ':'; +chdir $origdir; diff --git a/contrib/perl5/utils/splain.PL b/contrib/perl5/utils/splain.PL new file mode 100644 index 0000000..a638dba --- /dev/null +++ b/contrib/perl5/utils/splain.PL @@ -0,0 +1,49 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# 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: +# $startperl +# $perlpath +# $eunicefix + +# 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. +$origdir = cwd; +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +# Open input file before creating output file. +$IN = '../lib/diagnostics.pm'; +open IN or die "Can't open $IN: $!\n"; + +# Create output file. +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! + +while (<IN>) { + print OUT unless /^package diagnostics/; +} + +close IN; + +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 ':'; +chdir $origdir; |
