diff options
Diffstat (limited to 'contrib/perl5/utils')
| -rw-r--r-- | contrib/perl5/utils/Makefile | 57 | ||||
| -rw-r--r-- | contrib/perl5/utils/c2ph.PL | 1403 | ||||
| -rw-r--r-- | contrib/perl5/utils/dprofpp.PL | 838 | ||||
| -rw-r--r-- | contrib/perl5/utils/h2ph.PL | 746 | ||||
| -rw-r--r-- | contrib/perl5/utils/h2xs.PL | 1865 | ||||
| -rw-r--r-- | contrib/perl5/utils/perlbug.PL | 1224 | ||||
| -rw-r--r-- | contrib/perl5/utils/perlcc.PL | 667 | ||||
| -rw-r--r-- | contrib/perl5/utils/perldoc.PL | 875 | ||||
| -rw-r--r-- | contrib/perl5/utils/pl2pm.PL | 389 | ||||
| -rw-r--r-- | contrib/perl5/utils/splain.PL | 54 |
10 files changed, 0 insertions, 8118 deletions
diff --git a/contrib/perl5/utils/Makefile b/contrib/perl5/utils/Makefile deleted file mode 100644 index ec26cd8..0000000 --- a/contrib/perl5/utils/Makefile +++ /dev/null @@ -1,57 +0,0 @@ - -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 dprofpp.PL -plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc dprofpp -plextractexe = ./c2ph ./h2ph ./h2xs ./perlbug ./perldoc ./pl2pm ./splain ./perlcc ./dprofpp - -all: $(plextract) - -compile: all $(plextract) - $(REALPERL) -I../lib perlcc c2ph -o c2ph.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc h2ph -o h2ph.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc h2xs -o h2xs.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc perlbug -o perlbug.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc perldoc -o perldoc.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc pl2pm -o pl2pm.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc splain -o splain.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc perlcc -o perlcc.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc dprofpp -o dprofpp.exe -v 10 -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 - -dprofpp: dprofpp.PL ../config.sh - -clean: - -realclean: - rm -rf $(plextract) pstruct $(plextractexe) - rm -f ../t/_h2ph_pre.ph - -clobber: realclean - -distclean: clobber - -veryclean: distclean - -rm -f *~ *.org diff --git a/contrib/perl5/utils/c2ph.PL b/contrib/perl5/utils/c2ph.PL deleted file mode 100644 index 38b259f..0000000 --- a/contrib/perl5/utils/c2ph.PL +++ /dev/null @@ -1,1403 +0,0 @@ -#!/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/dprofpp.PL b/contrib/perl5/utils/dprofpp.PL deleted file mode 100644 index 51e8d78..0000000 --- a/contrib/perl5/utils/dprofpp.PL +++ /dev/null @@ -1,838 +0,0 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); - -# List explicitly here the variables you want Configure to -# generate. Metaconfig only looks for shell variables, so you -# have to mention them as if they were shell variables, not -# %Config entries. Thus you write -# $startperl -# to ensure Configure will look for $Config{startperl}. - -# This forces PL files to create target in same directory as PL file. -# This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// if ($Config{'osname'} eq 'OS2'); # "case-forgiving" -$file =~ s/\.pl$/.com/ if ($Config{'osname'} eq 'VMS'); # "case-forgiving" - -my $dprof_pm = '../ext/Devel/DProf/DProf.pm'; -my $VERSION = 0; -open( PM, "<$dprof_pm" ) || die "Can't open $dprof_pm: $!"; -while(<PM>){ - if( /^\$Devel::DProf::VERSION\s*=\s*'([\d._]+)'/ ){ - $VERSION = $1; - last; - } -} -close PM; -if( $VERSION == 0 ){ - die "Did not find VERSION in $dprof_pm"; -} -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 perl -S \$0 "\$@"' - if 0; - -require 5.003; - -my \$VERSION = '$VERSION'; - -!GROK!THIS! - -# In the following, perl variables are not expanded during extraction. - -print OUT <<'!NO!SUBS!'; -=head1 NAME - -dprofpp - display perl profile data - -=head1 SYNOPSIS - -dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [profile] - -dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile] - -dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile] - -dprofpp B<-p script> [B<-Q>] [other opts] - -dprofpp B<-V> [profile] - -=head1 DESCRIPTION - -The I<dprofpp> command interprets profile data produced by a profiler, such -as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and -will display the 15 subroutines which are using the most time. By default -the times for each subroutine are given exclusive of the times of their -child subroutines. - -To profile a Perl script run the perl interpreter with the B<-d> switch. So -to profile script F<test.pl> with Devel::DProf the following command should -be used. - - $ perl5 -d:DProf test.pl - -Then run dprofpp to analyze the profile. The output of dprofpp depends -on the flags to the program and the version of Perl you're using. - - $ dprofpp -u - Total Elapsed Time = 1.67 Seconds - User Time = 0.61 Seconds - Exclusive Times - %Time Seconds #Calls sec/call Name - 52.4 0.320 2 0.1600 main::foo - 45.9 0.280 200 0.0014 main::bar - 0.00 0.000 1 0.0000 DynaLoader::import - 0.00 0.000 1 0.0000 main::baz - -The dprofpp tool can also run the profiler before analyzing the profile -data. The above two commands can be executed with one dprofpp command. - - $ dprofpp -u -p test.pl - -Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile. - -=head1 OUTPUT - -Columns are: - -=over 4 - -=item %Time - -Percentage of time spent in this routine. - -=item #Calls - -Number of calls to this routine. - -=item sec/call - -Average number of seconds per call to this routine. - -=item Name - -Name of routine. - -=item CumulS - -Time (in seconds) spent in this routine and routines called from it. - -=item ExclSec - -Time (in seconds) spent in this routine (not including those called -from it). - -=item Csec/c - -Average time (in seconds) spent in each call of this routine -(including those called from it). - -=back - -=head1 OPTIONS - -=over 5 - -=item B<-a> - -Sort alphabetically by subroutine names. - -=item B<-A> - -Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>. -Otherwise the time to autoload it is counted as time of the subroutine -itself (there is no way to separate autoload time from run time). - -This is going to be irrelevant with newer Perls. They will inform -C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine, -so a separate statistics for C<AUTOLOAD> will be collected no matter -whether this option is set. - -=item B<-R> - -Count anonymous subroutines defined in the same package separately. - -=item B<-E> - -(default) Display all subroutine times exclusive of child subroutine times. - -=item B<-F> - -Force the generation of fake exit timestamps if dprofpp reports that the -profile is garbled. This is only useful if dprofpp determines that the -profile is garbled due to missing exit timestamps. You're on your own if -you do this. Consult the BUGS section. - -=item B<-I> - -Display all subroutine times inclusive of child subroutine times. - -=item B<-l> - -Sort by number of calls to the subroutines. This may help identify -candidates for inlining. - -=item B<-O cnt> - -Show only I<cnt> subroutines. The default is 15. - -=item B<-p script> - -Tells dprofpp that it should profile the given script and then interpret its -profile data. See B<-Q>. - -=item B<-Q> - -Used with B<-p> to tell dprofpp to quit after profiling the script, without -interpreting the data. - -=item B<-q> - -Do not display column headers. - -=item B<-r> - -Display elapsed real times rather than user+system times. - -=item B<-s> - -Display system times rather than user+system times. - -=item B<-T> - -Display subroutine call tree to stdout. Subroutine statistics are -not displayed. - -=item B<-t> - -Display subroutine call tree to stdout. Subroutine statistics are not -displayed. When a function is called multiple consecutive times at the same -calling level then it is displayed once with a repeat count. - -=item B<-S> - -Display I<merged> subroutine call tree to stdout. Statistics is -displayed for each branch of the tree. - -When a function is called multiple (I<not necessarily consecutive>) -times in the same branch then all these calls go into one branch of -the next level. A repeat count is output together with combined -inclusive, exclusive and kids time. - -Branches are sorted w.r.t. inclusive time. - -=item B<-U> - -Do not sort. Display in the order found in the raw profile. - -=item B<-u> - -Display user times rather than user+system times. - -=item B<-V> - -Print dprofpp's version number and exit. If a raw profile is found then its -XS_VERSION variable will be displayed, too. - -=item B<-v> - -Sort by average time spent in subroutines during each call. This may help -identify candidates for inlining. - -=item B<-z> - -(default) Sort by amount of user+system time used. The first few lines -should show you which subroutines are using the most time. - -=item B<-g> C<subroutine> - -Ignore subroutines except C<subroutine> and whatever is called from it. - -=back - -=head1 ENVIRONMENT - -The environment variable B<DPROFPP_OPTS> can be set to a string containing -options for dprofpp. You might use this if you prefer B<-I> over B<-E> or -if you want B<-F> on all the time. - -This was added fairly lazily, so there are some undesirable side effects. -Options on the commandline should override options in DPROFPP_OPTS--but -don't count on that in this version. - -=head1 BUGS - -Applications which call _exit() or exec() from within a subroutine -will leave an incomplete profile. See the B<-F> option. - -Any bugs in Devel::DProf, or any profiler generating the profile data, could -be visible here. See L<Devel::DProf/BUGS>. - -Mail bug reports and feature requests to the perl5-porters mailing list at -F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the -output of the B<-V> option. - -=head1 FILES - - dprofpp - profile processor - tmon.out - raw profile - -=head1 SEE ALSO - -L<perl>, L<Devel::DProf>, times(2) - -=cut - -use Getopt::Std 'getopts'; -use Config '%Config'; - -Setup: { - my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS'; - - $Monfile = 'tmon.out'; - if( exists $ENV{DPROFPP_OPTS} ){ - my @tmpargv = @ARGV; - @ARGV = split( ' ', $ENV{DPROFPP_OPTS} ); - getopts( $options ); - if( @ARGV ){ - # there was a filename. - $Monfile = shift; - } - @ARGV = @tmpargv; - } - - getopts( $options ); - if( @ARGV ){ - # there was a filename, it overrides any earlier name. - $Monfile = shift; - } - -# -O cnt Specifies maximum number of subroutines to display. -# -a Sort by alphabetic name of subroutines. -# -z Sort by user+system time spent in subroutines. (default) -# -l Sort by number of calls to subroutines. -# -v Sort by average amount of time spent in subroutines. -# -T Show call tree. -# -t Show call tree, compressed. -# -q Do not print column headers. -# -u Use user time rather than user+system time. -# -s Use system time rather than user+system time. -# -r Use real elapsed time rather than user+system time. -# -U Do not sort subroutines. -# -E Sub times are reported exclusive of child times. (default) -# -I Sub times are reported inclusive of child times. -# -V Print dprofpp's version. -# -p script Specifies name of script to be profiled. -# -Q Used with -p to indicate the dprofpp should quit after -# profiling the script, without interpreting the data. -# -A count autoloaded to *AUTOLOAD -# -R count anonyms separately even if from the same package -# -g subr count only those who are SUBR or called from SUBR -# -S Create statistics for all the depths - - if( defined $opt_V ){ - my $fh = 'main::fh'; - print "$0 version: $VERSION\n"; - open( $fh, "<$Monfile" ) && do { - local $XS_VERSION = 'early'; - header($fh); - close( $fh ); - print "XS_VERSION: $XS_VERSION\n"; - }; - exit(0); - } - $cnt = $opt_O || 15; - $sort = 'by_time'; - $sort = 'by_ctime' if defined $opt_I; - $sort = 'by_calls' if defined $opt_l; - $sort = 'by_alpha' if defined $opt_a; - $sort = 'by_avgcpu' if defined $opt_v; - $incl_excl = 'Exclusive'; - $incl_excl = 'Inclusive' if defined $opt_I; - $whichtime = 'User+System'; - $whichtime = 'System' if defined $opt_s; - $whichtime = 'Real' if defined $opt_r; - $whichtime = 'User' if defined $opt_u; - - if( defined $opt_p ){ - my $prof = 'DProf'; - my $startperl = $Config{'startperl'}; - - $startperl =~ s/^#!//; # remove shebang - run_profiler( $opt_p, $prof, $startperl ); - $Monfile = 'tmon.out'; # because that's where it is - exit(0) if defined $opt_Q; - } - elsif( defined $opt_Q ){ - die "-Q is meaningful only when used with -p\n"; - } -} - -Main: { - my $monout = $Monfile; - my $fh = 'main::fh'; - local $names = {}; - local $times = {}; # times in hz - local $ctimes = {}; # Cumulative times in hz - local $calls = {}; - local $persecs = {}; # times in seconds - local $idkeys = []; - local $runtime; # runtime in seconds - my @a = (); - my $a; - local $rrun_utime = 0; # user time in hz - local $rrun_stime = 0; # system time in hz - local $rrun_rtime = 0; # elapsed run time in hz - local $rrun_ustime = 0; # user+system time in hz - local $hz = 0; - local $deep_times = {count => 0 , kids => {}, incl_time => 0}; - local $time_precision = 2; - local $overhead = 0; - - open( $fh, "<$monout" ) || die "Unable to open $monout\n"; - - header($fh); - - $rrun_ustime = $rrun_utime + $rrun_stime; - - $~ = 'STAT'; - if( ! $opt_q ){ - $^ = 'CSTAT_top'; - } - - parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys ); - - settime( \$runtime, $hz ) unless $opt_g; - - exit(0) if $opt_T || $opt_t; - - if( $opt_v ){ - percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys ); - } - if( ! $opt_U ){ - @a = sort $sort @$idkeys; - $a = \@a; - } - else { - $a = $idkeys; - } - display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a, - $deep_times); -} - - -# Sets $runtime to user, system, real, or user+system time. The -# result is given in seconds. -# -sub settime { - my( $runtime, $hz ) = @_; - - $hz ||= 1; - - if( $opt_r ){ - $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz; - } - elsif( $opt_s ){ - $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz; - } - elsif( $opt_u ){ - $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz; - } - else{ - $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz; - } - $$runtime = 0 unless $$runtime > 0; -} - -sub exclusives_in_tree { - my( $deep_times ) = @_; - my $kids_time = 0; - my $kid; - # When summing, take into account non-rounded-up kids time. - for $kid (keys %{$deep_times->{kids}}) { - $kids_time += $deep_times->{kids}{$kid}{incl_time}; - } - $kids_time = 0 unless $kids_time >= 0; - $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time; - $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0; - for $kid (keys %{$deep_times->{kids}}) { - exclusives_in_tree($deep_times->{kids}{$kid}); - } - $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0; - $deep_times->{kids_time} = $kids_time; -} - -sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time} - or $a cmp $b } - -sub display_tree { - my( $deep_times, $name, $level ) = @_; - exclusives_in_tree($deep_times); - - my $kid; - local *kids = $deep_times->{kids}; # %kids - - my $time; - if (%kids) { - $time = sprintf '%.*fs = (%.*f + %.*f)', - $time_precision, $deep_times->{incl_time}/$hz, - $time_precision, $deep_times->{excl_time}/$hz, - $time_precision, $deep_times->{kids_time}/$hz; - } else { - $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz; - } - print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n" - if $deep_times->{count}; - - for $kid (sort kids_by_incl keys %kids) { - display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 ); - } -} - -# Report the times in seconds. -sub display { - my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, - $idkeys, $deep_times ) = @_; - my( $x, $key, $s, $cs ); - #format: $ncalls, $name, $secs, $percall, $pcnt - - if ($opt_S) { - display_tree( $deep_times, 'toplevel', -1 ) - } else { - for( $x = 0; $x < @$idkeys; ++$x ){ - $key = $idkeys->[$x]; - $ncalls = $calls->{$key}; - $name = $names->{$key}; - $s = $times->{$key}/$hz; - $secs = sprintf("%.3f", $s ); - $cs = $ctimes->{$key}/$hz; - $csecs = sprintf("%.3f", $cs ); - $percall = sprintf("%.4f", $s/$ncalls ); - $cpercall = sprintf("%.4f", $cs/$ncalls ); - $pcnt = sprintf("%.2f", - $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 ); - write; - $pcnt = $secs = $ncalls = $percall = ""; - write while( length $name ); - last unless --$cnt; - } - } -} - -sub move_keys { - my ($source, $dest) = @_; - my $kid; - - for $kid (keys %$source) { - if (exists $dest->{$kid}) { - $dest->{count} += $source->{count}; - $dest->{incl_time} += $source->{incl_time}; - move_keys($source->{kids},$dest->{kids}); - } else { - $dest->{$kid} = delete $source->{$kid}; - } - } -} - -sub add_to_tree { - my ($curdeep_times, $name, $t) = @_; - if ($name ne $curdeep_times->[-1]{name} and $opt_A) { - $name = $curdeep_times->[-1]{name}; - } - die "Shorted?!" unless @$curdeep_times >= 2; - $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {}, - incl_time => 0, - } - unless exists $curdeep_times->[-2]{kids}{$name}; - my $entry = $curdeep_times->[-2]{kids}{$name}; - # Now transfer to the new node (could not do earlier, since name can change) - $entry->{count}++; - $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp}; - # Merge the kids? - move_keys($curdeep_times->[-1]->{kids},$entry->{kids}); - pop @$curdeep_times; -} - -sub parsestack { - my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_; - my( $dir, $name ); - my( $t, $syst, $realt, $usert ); - my( $x, $z, $c, $id, $pack ); - my @stack = (); - my @tstack = (); - my $tab = 3; - my $in = 0; - - # remember last call depth and function name - my $l_in = $in; - my $l_name = ''; - my $repcnt = 0; - my $repstr = ''; - my $dprof_t = 0; - my $dprof_stamp; - my %cv_hash; - my $in_level = not defined $opt_g; # Level deep in report grouping - my $curdeep_times = [$deep_times]; - - my $over_per_call; - if ( $opt_u ) { $over_per_call = $over_utime } - elsif( $opt_s ) { $over_per_call = $over_stime } - elsif( $opt_r ) { $over_per_call = $over_rtime } - else { $over_per_call = $over_utime + $over_stime } - $over_per_call /= 2*$over_tests; # distribute over entry and exit - - while(<$fh>){ - next if /^#/; - last if /^PART/; - - chop; - if (/^&/) { - ($dir, $id, $pack, $name) = split; - if ($opt_R and ($name =~ /::(__ANON_|END)$/)) { - $name .= "($id)"; - } - $cv_hash{$id} = "$pack\::$name"; - next; - } - ($dir, $usert, $syst, $realt, $name) = split; - - my $ot = $t; - if ( $dir eq '/' ) { - $syst = $stack[-1][0]; - $usert = '&'; - $dir = '-'; - #warn("Inserted exit for $stack[-1][0].\n") - } - if (defined $realt) { # '+ times nam' '- times nam' or '@ incr' - if ( $opt_u ) { $t = $usert } - elsif( $opt_s ) { $t = $syst } - elsif( $opt_r ) { $t = $realt } - else { $t = $usert + $syst } - $t += $ot, next if $dir eq '@'; # Increments there - } else { - # "- id" or "- & name" - $name = defined $syst ? $syst : $cv_hash{$usert}; - } - - next unless $in_level or $name eq $opt_g or $dir eq '*'; - if ( $dir eq '-' or $dir eq '*' ) { - my $ename = $dir eq '*' ? $stack[-1][0] : $name; - $overhead += $over_per_call; - if ($name eq "Devel::DProf::write") { - $dprof_t += $t - $dprof_stamp; - next; - } elsif (defined $opt_g and $ename eq $opt_g) { - $in_level--; - } - add_to_tree($curdeep_times, $ename, - $t - $dprof_t - $overhead) if $opt_S; - exitstamp( \@stack, \@tstack, - $t - $dprof_t - $overhead, - $times, $ctimes, $ename, \$in, $tab, - $curdeep_times ); - } - next unless $in_level or $name eq $opt_g; - if( $dir eq '+' or $dir eq '*' ){ - if ($name eq "Devel::DProf::write") { - $dprof_stamp = $t; - next; - } elsif (defined $opt_g and $name eq $opt_g) { - $in_level++; - } - $overhead += $over_per_call; - if( $opt_T ){ - print ' ' x $in, "$name\n"; - $in += $tab; - } - elsif( $opt_t ){ - # suppress output on same function if the - # same calling level is called. - if ($l_in == $in and $l_name eq $name) { - $repcnt++; - } else { - $repstr = ' ('.++$repcnt.'x)' - if $repcnt; - print ' ' x $l_in, "$l_name$repstr\n" - if $l_name ne ''; - $repstr = ''; - $repcnt = 0; - $l_in = $in; - $l_name = $name; - } - $in += $tab; - } - if( ! defined $names->{$name} ){ - $names->{$name} = $name; - $times->{$name} = 0; - $ctimes->{$name} = 0; - push( @$idkeys, $name ); - } - $calls->{$name}++; - push @$curdeep_times, { kids => {}, - name => $name, - enter_stamp => $t - $dprof_t - $overhead, - } if $opt_S; - $x = [ $name, $t - $dprof_t - $overhead ]; - push( @stack, $x ); - - # my children will put their time here - push( @tstack, 0 ); - } elsif ($dir ne '-'){ - die "Bad profile: $_"; - } - } - if( $opt_t ){ - $repstr = ' ('.++$repcnt.'x)' if $repcnt; - print ' ' x $l_in, "$l_name$repstr\n"; - } - - if( @stack ){ - if( ! $opt_F ){ - warn "Garbled profile is missing some exit time stamps:\n"; - foreach $x (@stack) { - print $x->[0],"\n"; - } - die "Try rerunning dprofpp with -F.\n"; - # I don't want -F to be default behavior--yet - # 9/18/95 dmr - } - else{ - warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n"); - foreach $x ( reverse @stack ){ - $name = $x->[0]; - exitstamp( \@stack, \@tstack, - $t - $dprof_t - $overhead, $times, - $ctimes, $name, \$in, $tab, - $curdeep_times ); - add_to_tree($curdeep_times, $name, - $t - $dprof_t - $overhead) - if $opt_S; - } - } - } - if (defined $opt_g) { - $runtime = $ctimes->{$opt_g}/$hz; - $runtime = 0 unless $runtime > 0; - } -} - -sub exitstamp { - my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_; - my( $x, $c, $z ); - - $x = pop( @$stack ); - if( ! defined $x ){ - die "Garbled profile, missing an enter time stamp"; - } - if( $x->[0] ne $name ){ - if ($x->[0] =~ /::AUTOLOAD$/) { - if ($opt_A) { - $name = $x->[0]; - } - } elsif ( $opt_F ) { - warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n"); - $name = $x->[0]; - } else { - foreach $z (@stack, $x) { - print $z->[0],"\n"; - } - die "Garbled profile, unexpected exit time stamp"; - } - } - if( $opt_T || $opt_t ){ - $$in -= $tab; - } - # collect childtime - $c = pop( @$tstack ); - # total time this func has been active - $z = $t - $x->[1]; - $ctimes->{$name} += $z; - $times->{$name} += ($z > $c)? $z - $c: 0; - # pass my time to my parent - if( @$tstack ){ - $c = pop( @$tstack ); - push( @$tstack, $c + $z ); - } -} - - -sub header { - my $fh = shift; - chop($_ = <$fh>); - if( ! /^#fOrTyTwO$/ ){ - die "Not a perl profile"; - } - while(<$fh>){ - next if /^#/; - last if /^PART/; - eval; - } - $over_tests = 1 unless $over_tests; - $time_precision = length int ($hz - 1); # log ;-) -} - - -# Report avg time-per-function in seconds -sub percalc { - my( $calls, $times, $persecs, $idkeys ) = @_; - my( $x, $t, $n, $key ); - - for( $x = 0; $x < @$idkeys; ++$x ){ - $key = $idkeys->[$x]; - $n = $calls->{$key}; - $t = $times->{$key} / $hz; - $persecs->{$key} = $t ? $t / $n : 0; - } -} - - -# Runs the given script with the given profiler and the given perl. -sub run_profiler { - my $script = shift; - my $profiler = shift; - my $startperl = shift; - - system $startperl, "-d:$profiler", $script; - if( $? / 256 > 0 ){ - die "Failed: $startperl -d:$profiler $script: $!"; - } -} - - -sub by_time { $times->{$b} <=> $times->{$a} } -sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} } -sub by_calls { $calls->{$b} <=> $calls->{$a} } -sub by_alpha { $names->{$a} cmp $names->{$b} } -sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} } - - -format CSTAT_top = -Total Elapsed Time = @>>>>>>> Seconds -(($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz) - @>>>>>>>>>> Time = @>>>>>>> Seconds -$whichtime, $runtime -@<<<<<<<< Times -$incl_excl -%Time ExclSec CumulS #Calls sec/call Csec/c Name -. - -format STAT = - ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name -. - -!NO!SUBS! - -close OUT or die "Can't close $file: $!"; -chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; -exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/contrib/perl5/utils/h2ph.PL b/contrib/perl5/utils/h2ph.PL deleted file mode 100644 index 6f012dc..0000000 --- a/contrib/perl5/utils/h2ph.PL +++ /dev/null @@ -1,746 +0,0 @@ -#!/usr/local/bin/perl -# $FreeBSD$ - -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 strict; - -use Config; -use File::Path qw(mkpath); -use Getopt::Std; - -getopts('Dd:rlhaQ'); -use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q); -die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); -my @inc_dirs = inc_dirs() if $opt_a; - -my $Exit = 0; - -my $Dest_dir = $opt_d || $Config{installarchlib}; -die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" - unless -d $Dest_dir; - -my @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 - -my %isatype; -@isatype{@isatype} = (1) x @isatype; -my $inif = 0; -my %Is_converted; - -@ARGV = ('-') unless @ARGV; - -build_preamble_if_necessary(); - -my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile); -my ($incl, $next); -while (defined (my $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"; - } - - print OUT "require '_h2ph_pre.ph';\n\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 my $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 { - # Shunt around such directives as `#define FOO FOO': - next if " \&$name" eq $new; - - 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(/^error\s+(.*)/) { - print OUT $t, "die(\"", quotemeta($1), "\");\n"; - } elsif(/^warning\s+(.*)/) { - print OUT $t, "warn(\"", quotemeta($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?;/; - (my $enum_subs = $3) =~ s/\s//g; - my @enum_subs = split(/,/, $enum_subs); - my $enum_val = -1; - foreach my $enum (@enum_subs) { - my ($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 { - my $joined_args; - if(keys(%curargs)) { - $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 { - my $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 { - my $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}); -} - - -# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different -# version of h2ph. -sub build_preamble_if_necessary -{ - # Increment $VERSION every time this function is modified: - my $VERSION = 2; - my $preamble = "$Dest_dir/_h2ph_pre.ph"; - - # Can we skip building the preamble file? - if (-r $preamble) { - # Extract version number from first line of preamble: - open PREAMBLE, $preamble or die "Cannot open $preamble: $!"; - my $line = <PREAMBLE>; - $line =~ /(\b\d+\b)/; - close PREAMBLE or die "Cannot close $preamble: $!"; - - # Don't build preamble if a compatible preamble exists: - return if $1 == $VERSION; - } - - my (%define) = _extract_cc_defines(); - - open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!"; - print PREAMBLE "# This file was created by h2ph version $VERSION\n"; - - foreach (sort keys %define) { - if ($opt_D) { - print PREAMBLE "# $_=$define{$_}\n"; - } - - if ($define{$_} =~ /^\d+$/) { - print PREAMBLE - "unless (defined &$_) { sub $_() { $define{$_} } }\n\n"; - } elsif ($define{$_} =~ /^\w+$/) { - print PREAMBLE - "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n"; - } else { - print PREAMBLE - "unless (defined &$_) { sub $_() { \"", - quotemeta($define{$_}), "\" } }\n\n"; - } - } - close PREAMBLE or die "Cannot close $preamble: $!"; -} - - -# %Config contains information on macros that are pre-defined by the -# system's compiler. We need this information to make the .ph files -# function with perl as the .h files do with cc. -sub _extract_cc_defines -{ - my %define; - my $allsymbols = join " ", - @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'}; - - # Split compiler pre-definitions into `key=value' pairs: - foreach (split /\s+/, $allsymbols) { - /(.+?)=(.+)/ and $define{$1} = $2; - - if ($opt_D) { - print STDERR "$_: $1 -> $2\n"; - } - } - - return %define; -} - - -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{'installarchlib'}>). - -=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>. - -=item -Q - -``Quiet'' mode; don't print out the names of the files being converted. - -=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. - -You have to run this program by hand; it's not run as part of the Perl -installation. - -Doesn't handle complicated expressions built piecemeal, a la: - - enum { - FIRST_VALUE, - SECOND_VALUE, - #ifdef ABC - THIRD_VALUE - #endif - }; - -Doesn't necessarily locate all of your C compiler's internally-defined -symbols. - -=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 deleted file mode 100644 index edc2bb5..0000000 --- a/contrib/perl5/utils/h2xs.PL +++ /dev/null @@ -1,1865 +0,0 @@ -#!/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. -my $origdir = cwd; -chdir dirname($0); -my $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<-ACOPXacdfkmx>] [B<-F> addflags] [B<-M> fmask] [B<-n> module_name] [B<-o> tmask] [B<-p> prefix] [B<-s> subs] [B<-v> version] [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<use AutoLoader>> statement from the .pm file. - -=item B<-C> - -Omits creation of the F<Changes> file, and adds a HISTORY section to -the POD template. - -=item B<-F> I<addflags> - -Additional flags to specify to C preprocessor when scanning header for -function declarations. Should not be used without B<-x>. - -=item B<-M> I<regular expression> - -selects functions/macros to process. - -=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. C<-c> and C<-f> are implicitly enabled. - -=item B<-a> - -Generate an accessor method for each element of structs and unions. The -generated methods are named after the element name; will return the current -value of the element if called without additional arguments; and will set -the element to the supplied value (and return the new value) if called with -an additional argument. Embedded structures and unions are returned as a -pointer rather than the complete structure, to facilitate chained calls. - -These methods all apply to the Ptr type for the structure; additionally -two methods are constructed for the structure type itself, C<_to_ptr> -which returns a Ptr type pointing to the same structure, and a C<new> -method to construct and return a new structure, initialised to zeroes. - -=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 standard include directories. - -=item B<-h> - -Print the usage, help and version for this h2xs and exit. - -=item B<-k> - -For function arguments declared as C<const>, omit the const attribute in the -generated XS code. - -=item B<-m> - -B<Experimental>: for each variable declared in the header file(s), declare -a perl variable of the same name magically tied to the C variable. - -=item B<-n> I<module_name> - -Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> - -=item B<-o> I<regular expression> - -Use "opaque" data type for the C types matched by the regular -expression, even if these types are C<typedef>-equivalent to types -from typemaps. Should not be used without B<-x>. - -This may be useful since, say, types which are C<typedef>-equivalent -to integers may represent OS-related handles, and one may want to work -with these handles in OO-way, as in C<$handle-E<gt>do_something()>. -Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types. - -The type-to-match is whitewashed (except for commas, which have no -whitespace before them, and multiple C<*> which have no whitespace -between them). - -=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()> mechanism. - -=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. See -also the section on L<LIMITATIONS of B<-x>>. - -=item B<-b> I<version> - -Generates a .pm file which is backwards compatible with the specified -perl version. - -For versions < 5.6.0, the changes are. - - no use of 'our' (uses 'use vars' instead) - - no 'use warnings' - -Specifying a compatibility version higher than the version of perl you -are using to run h2xs will have no effect. - -=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 - - # Same but select only functions which match /^av_/ - h2xs -M '^av_' -xAn perl2 perl.h,proto.h - - # Same but treat SV* etc as "opaque" types - h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h - -=head2 Extension based on F<.h> and F<.c> files - -Suppose that you have some C files implementing some functionality, -and the corresponding header files. How to create an extension which -makes this functionality accessable in Perl? The example below -assumes that the header files are F<interface_simple.h> and -I<interface_hairy.h>, and you want the perl module be named as -C<Ext::Ension>. If you need some preprocessor directives and/or -linking with external libraries, see the flags C<-F>, C<-L> and C<-l> -in L<"OPTIONS">. - -=over - -=item Find the directory name - -Start with a dummy run of h2xs: - - h2xs -Afn Ext::Ension - -The only purpose of this step is to create the needed directories, and -let you know the names of these directories. From the output you can -see that the directory for the extension is F<Ext/Ension>. - -=item Copy C files - -Copy your header files and C files to this directory F<Ext/Ension>. - -=item Create the extension - -Run h2xs, overwriting older autogenerated files: - - h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h - -h2xs looks for header files I<after> changing to the extension -directory, so it will find your header files OK. - -=item Archive and test - -As usual, run - - cd Ext/Ension - perl Makefile.PL - make dist - make - make test - -=item Hints - -It is important to do C<make dist> as early as possible. This way you -can easily merge(1) your changes to autogenerated files if you decide -to edit your C<.h> files and rerun h2xs. - -Do not forget to edit the documentation in the generated F<.pm> file. - -Consider the autogenerated files as skeletons only, you may invent -better interfaces than what h2xs could guess. - -Consider this section as a guideline only, some other options of h2xs -may better suit your needs. - -=back - -=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. - -=head1 LIMITATIONS of B<-x> - -F<h2xs> would not distinguish whether an argument to a C function -which is of the form, say, C<int *>, is an input, output, or -input/output parameter. In particular, argument declarations of the -form - - int - foo(n) - int *n - -should be better rewritten as - - int - foo(n) - int &n - -if C<n> is an input parameter. - -Additionally, F<h2xs> has no facilities to intuit that a function - - int - foo(addr,l) - char *addr - int l - -takes a pair of address and length of data at this address, so it is better -to rewrite this function as - - int - foo(sv) - SV *addr - PREINIT: - STRLEN len; - char *s; - CODE: - s = SvPV(sv,len); - RETVAL = foo(s, len); - OUTPUT: - RETVAL - -or alternately - - static int - my_foo(SV *sv) - { - STRLEN len; - char *s = SvPV(sv,len); - - return foo(s, len); - } - - MODULE = foo PACKAGE = foo PREFIX = my_ - - int - foo(sv) - SV *sv - -See L<perlxs> and L<perlxstut> for additional details. - -=cut - -use strict; - - -my( $H2XS_VERSION ) = ' $Revision: 1.21 $ ' =~ /\$Revision:\s+([^\s]+)/; -my $TEMPLATE_VERSION = '0.01'; -my @ARGS = @ARGV; -my $compat_version = $]; - -use Getopt::Std; - -sub usage{ - warn "@_\n" if @_; - die "h2xs [-ACOPXacdfhkmx] [-F addflags] [-M fmask] [-n module_name] [-o tmask] [-p prefix] [-s subs] [-v version] [headerfile [extra_libraries]] -version: $H2XS_VERSION - -A Omit all autoloading facilities (implies -c). - -C Omit creating the Changes file, add HISTORY heading to stub POD. - -F Additional flags for C preprocessor (used with -x). - -M Mask to select C functions/macros (default is select all). - -O Allow overwriting of a pre-existing extension directory. - -P Omit the stub POD section. - -X Omit the XS portion (implies both -c and -f). - -a Generate get/set accessors for struct and union members (used with -x). - -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 - -k Omit 'const' attribute on function arguments (used with -x). - -m Generate tied variables for access to declared variables. - -n Specify a name to use for the extension (recommended). - -o Regular expression for \"opaque\" types. - -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. - -b Specify a perl version to be backwards compatibile with -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("ACF:M:OPXacdfhkmn:o:p:s:v:xb:") || usage; -use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d - $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x - $opt_b); - -usage if $opt_h; - -if( $opt_b ){ - usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m); - $opt_b =~ /^\d+\.\d+\.\d+/ || - usage "You must provide the backwards compatibility version in X.Y.Z form. " . - "(i.e. 5.5.0)\n"; - my ($maj,$min,$sub) = split(/\./,$opt_b,3); - $compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub); -} - -if( $opt_v ){ - $TEMPLATE_VERSION = $opt_v; -} - -# -A implies -c. -$opt_c = 1 if $opt_A; - -# -X implies -c and -f -$opt_c = $opt_f = 1 if $opt_X; - -my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; -my $extralibs; -my @path_h; - -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); - -my $fmask; -my $tmask; - -$fmask = qr{$opt_M} if defined $opt_M; -$tmask = qr{$opt_o} if defined $opt_o; -my $tmask_all = $tmask && $opt_o eq '.'; - -if ($opt_x) { - eval {require C::Scan; 1} - or die <<EOD; -C::Scan required if you use -x option. -To install C::Scan, execute - perl -MCPAN -e "install C::Scan" -EOD - unless ($tmask_all) { - $C::Scan::VERSION >= 0.70 - or die <<EOD; -C::Scan v. 0.70 or later required unless you use -o . option. -You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. -To install C::Scan, execute - perl -MCPAN -e "install C::Scan" -EOD - } - if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) { - die <<EOD; -C::Scan v. 0.73 or later required to use -m or -a options. -You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. -To install C::Scan, execute - perl -MCPAN -e "install C::Scan" -EOD - } -} -elsif ($opt_o or $opt_F) { - warn <<EOD; -Options -o and -F do not make sense without -x. -EOD -} - -my @path_h_ini = @path_h; -my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names); - -my $module = $opt_n; - -if( @path_h ){ - use Config; - use File::Spec; - my @paths; - if ($^O eq 'VMS') { # Consider overrides of default location - # XXXX This is not equivalent to what the older version did: - # it was looking at $hadsys header-file per header-file... - my($hadsys) = grep s!^sys/!!i , @path_h; - @paths = qw( Sys$Library VAXC$Include ); - push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]'); - push @paths, qw( DECC$Library_Include DECC$System_Include ); - } - else { - @paths = (File::Spec->curdir(), $Config{usrinc}, - (split ' ', $Config{locincpth}), '/usr/include'); - } - foreach my $path_h (@path_h) { - $name ||= $path_h; - $module ||= do { - $name =~ s/\.h$//; - if ( $name !~ /::/ ) { - $name =~ s#^.*/##; - $name = "\u$name"; - } - $name; - }; - - if( $path_h =~ s#::#/#g && $opt_n ){ - warn "Nesting of headerfile ignored with -n\n"; - } - $path_h .= ".h" unless $path_h =~ /\.h$/; - my $fullpath = $path_h; - $path_h =~ s/,.*$// if $opt_x; - $fullpath{$path_h} = $fullpath; - - # Minor trickery: we can't chdir() before we processed the headers - # (so know the name of the extension), but the header may be in the - # extension directory... - my $tmp_path_h = $path_h; - my $rel_path_h = $path_h; - my @dirs = @paths; - if (not -f $path_h) { - my $found; - for my $dir (@paths) { - $found++, last - if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); - } - if ($found) { - $rel_path_h = $path_h; - } else { - (my $epath = $module) =~ s,::,/,g; - $epath = File::Spec->catdir('ext', $epath) if -d 'ext'; - $rel_path_h = File::Spec->catfile($epath, $tmp_path_h); - $path_h = $tmp_path_h; # Used during -x - push @dirs, $epath; - } - } - - if (!$opt_c) { - die "Can't find $tmp_path_h in @dirs\n" - if ( ! $opt_f && ! -f "$rel_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, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n"; - defines: - while (<CH>) { - if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) { - my $def = $1; - my $rest = $2; - $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments - $rest =~ s/^\s+//; - $rest =~ s/\s+$//; - # Cannot do: (-1) and ((LHANDLE)3) are OK: - #print("Skip non-wordy $def => $rest\n"), - # next defines if $rest =~ /[^\w\$]/; - if ($rest =~ /"/) { - print("Skip stringy $def => $rest\n") if $opt_d; - next defines; - } - print "Matched $_ ($def)\n" if $opt_d; - $seen_define{$def} = $rest; - $_ = $def; - 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"; - } - } - $prefixless{$def} = $_; - if (!$fmask or /$fmask/) { - print "... Passes mask of -M.\n" if $opt_d and $fmask; - $const_names{$_}++; - } - } - } - close(CH); - } - } -} - - - -my ($ext, $nested, @modparts, $modfname, $modpname); -(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 ){ - my $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 = []; -my $typedef_rex; -my %typedefs_pre; -my %known_fnames; -my %structs; - -my @fnames; -my @fnames_no_prefix; -my %vdecl_hash; -my @vdecls; - -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 Config; # Run-time directive - warn "Scanning typemaps...\n"; - get_typemap(); - my @td; - my @good_td; - my $addflags = $opt_F || ''; - - foreach my $filename (@path_h) { - my $c; - my $filter; - - if ($fullpath{$filename} =~ /,/) { - $filename = $`; - $filter = $'; - } - warn "Scanning $filename for functions...\n"; - $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, - 'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)]; - $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); - - push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; - push(@$fdecls, @{$c->get('fdecls')}); - - push @td, @{$c->get('typedefs_maybe')}; - if ($opt_a) { - my $structs = $c->get('typedef_structs'); - @structs{keys %$structs} = values %$structs; - } - - if ($opt_m) { - %vdecl_hash = %{ $c->get('vdecl_hash') }; - @vdecls = sort keys %vdecl_hash; - for (local $_ = 0; $_ < @vdecls; ++$_) { - my $var = $vdecls[$_]; - my($type, $post) = @{ $vdecl_hash{$var} }; - if (defined $post) { - warn "Can't handle variable '$type $var $post', skipping.\n"; - splice @vdecls, $_, 1; - redo; - } - $type = normalize_type($type); - $vdecl_hash{$var} = $type; - } - } - - unless ($tmask_all) { - warn "Scanning $filename for typedefs...\n"; - my $td = $c->get('typedef_hash'); - # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d; - my @f_good_td = grep $td->{$_}[1] eq '', keys %$td; - push @good_td, @f_good_td; - @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td}; - } - } - { local $" = '|'; - $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td; - } - %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT - if ($fmask) { - my @good; - for my $i (0..$#$fdecls_parsed) { - next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME - push @good, $i; - print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n" - if $opt_d; - } - $fdecls = [@$fdecls[@good]]; - $fdecls_parsed = [@$fdecls_parsed[@good]]; - } - @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME - # Sort declarations: - { - my %h = map( ($_->[1], $_), @$fdecls_parsed); - $fdecls_parsed = [ @h{@fnames} ]; - } - @fnames_no_prefix = @fnames; - @fnames_no_prefix - = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix; - # Remove macros which expand to typedefs - print "Typedefs are @td.\n" if $opt_d; - my %td = map {($_, $_)} @td; - # Add some other possible but meaningless values for macros - for my $k (qw(char double float int long short unsigned signed void)) { - $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned '); - } - # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@; - my $n = 0; - my %bad_macs; - while (keys %td > $n) { - $n = keys %td; - my ($k, $v); - while (($k, $v) = each %seen_define) { - # print("found '$k'=>'$v'\n"), - $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; - } - } - # Now %bad_macs contains names of bad macros - for my $k (keys %bad_macs) { - delete $const_names{$prefixless{$k}}; - print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d; - } - } -} -my @const_names = sort keys %const_names; - -open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; - -$" = "\n\t"; -warn "Writing $ext$modpname/$modfname.pm\n"; - -if ( $compat_version < 5.006 ) { -print PM <<"END"; -package $module; - -use $compat_version; -use strict; -END -} -else { -print PM <<"END"; -package $module; - -use 5.006; -use strict; -use warnings; -END -} - -unless( $opt_X || $opt_c || $opt_A ){ - # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and - # will want Carp. - print PM <<'END'; -use Carp; -END -} - -print PM <<'END'; - -require Exporter; -END - -print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled -require DynaLoader; -END - - -# Are we using AutoLoader or not? -unless ($opt_A) { # no autoloader whatsoever. - unless ($opt_c) { # we're doing the AUTOLOAD - print PM "use AutoLoader;\n"; - } - else { - print PM "use AutoLoader qw(AUTOLOAD);\n" - } -} - -if ( $compat_version < 5.006 ) { - if ( $opt_X || $opt_c || $opt_A ) { - print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);'; - } else { - print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);'; - } -} - -# Determine @ISA. -my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. -$myISA .= ' DynaLoader' unless $opt_X; # no XS -$myISA .= ');'; -$myISA =~ s/^our // if $compat_version < 5.006; - -print PM "\n$myISA\n\n"; - -my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); - -my $tmp=<<"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. - -# This allows declaration use $module ':all'; -# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK -# will save memory. -our %EXPORT_TAGS = ( 'all' => [ qw( - @exported_names -) ] ); - -our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); - -our \@EXPORT = qw( - @const_names -); -our \$VERSION = '$TEMPLATE_VERSION'; - -END - -$tmp =~ s/^our //mg if $compat_version < 5.006; -print PM $tmp; - -if (@vdecls) { - printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; -} - - -$tmp = ( $compat_version < 5.006 ? "" : "our \$AUTOLOAD;" ); -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; - $tmp - (\$constname = \$AUTOLOAD) =~ s/.*:://; - croak "&$module::constant not defined" if \$constname eq 'constant'; - my \$val = constant(\$constname, \@_ ? \$_[0] : 0); - if (\$! != 0) { - if (\$! =~ /Invalid/ || \$!{EINVAL}) { - \$AutoLoader::AUTOLOAD = \$AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - croak "Your vendor has not defined $module macro \$constname"; - } - } - { - no strict 'refs'; - # Fixed between 5.005_53 and 5.005_61 - if (\$] >= 5.00561) { - *\$AUTOLOAD = sub () { \$val }; - } - else { - *\$AUTOLOAD = sub { \$val }; - } - } - goto &\$AUTOLOAD; -} - -END - -if( ! $opt_X ){ # print bootstrap, unless XS is disabled - print PM <<"END"; -bootstrap $module \$VERSION; -END -} - -# tying the variables can happen only after bootstrap -if (@vdecls) { - printf PM <<END; -{ -@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]} -} - -END -} - -my $after; -if( $opt_P ){ # if POD is disabled - $after = '__END__'; -} -else { - $after = '=cut'; -} - -print PM <<"END"; - -# Preloaded methods go here. -END - -print PM <<"END" unless $opt_A; - -# Autoload methods go after $after, and are processed by the autosplit program. -END - -print PM <<"END"; - -1; -__END__ -END - -my $author = "A. U. Thor"; -my $email = 'a.u.thor@a.galaxy.far.far.away'; - -my $revhist = ''; -$revhist = <<EOT if $opt_C; -# -#=head1 HISTORY -# -#=over 8 -# -#=item $TEMPLATE_VERSION -# -#Original version; created by h2xs $H2XS_VERSION with options -# -# @ARGS -# -#=back -# -EOT - -my $exp_doc = <<EOD; -# -#=head2 EXPORT -# -#None by default. -# -EOD - -if (@const_names and not $opt_P) { - $exp_doc .= <<EOD; -#=head2 Exportable constants -# -# @{[join "\n ", @const_names]} -# -EOD -} - -if (defined $fdecls and @$fdecls and not $opt_P) { - $exp_doc .= <<EOD; -#=head2 Exportable functions -# -EOD - -# $exp_doc .= <<EOD if $opt_p; -#When accessing these functions from Perl, prefix C<$opt_p> should be removed. -# -#EOD - $exp_doc .= <<EOD; -# @{[join "\n ", @known_fnames{@fnames}]} -# -EOD -} - -my $meth_doc = ''; - -if ($opt_x && $opt_a) { - my($name, $struct); - $meth_doc .= accessor_docs($name, $struct) - while ($name, $struct) = each %structs; -} - -my $pod = <<"END" unless $opt_P; -## Below is stub 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, created by h2xs. It looks like the -#author of the extension was negligent enough to leave the stub -#unedited. -# -#Blah blah blah. -$exp_doc$meth_doc$revhist -#=head1 AUTHOR -# -#$author, E<lt>${email}E<gt> -# -#=head1 SEE ALSO -# -#L<perl>. -# -#=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"; -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -END -if( @path_h ){ - foreach my $path_h (@path_h_ini) { - 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"; -} - -my %pointer_typedefs; -my %struct_typedefs; - -sub td_is_pointer { - my $type = shift; - my $out = $pointer_typedefs{$type}; - return $out if defined $out; - my $otype = $type; - $out = ($type =~ /\*$/); - # This converts only the guys which do not have trailing part in the typedef - if (not $out - and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { - $type = normalize_type($type); - print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n" - if $opt_d; - $out = td_is_pointer($type); - } - return ($pointer_typedefs{$otype} = $out); -} - -sub td_is_struct { - my $type = shift; - my $out = $struct_typedefs{$type}; - return $out if defined $out; - my $otype = $type; - $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type); - # This converts only the guys which do not have trailing part in the typedef - if (not $out - and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { - $type = normalize_type($type); - print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n" - if $opt_d; - $out = td_is_struct($type); - } - return ($struct_typedefs{$otype} = $out); -} - -# Some macros will bomb if you try to return them from a double-returning func. -# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen). -# Fortunately, we can detect both these cases... -sub protect_convert_to_double { - my $in = shift; - my $val; - return '' unless defined ($val = $seen_define{$in}); - return '(IV)' if $known_fnames{$val}; - # OUT_t of ((OUT_t)-1): - return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/; - td_is_pointer($2) ? '(IV)' : ''; -} - -# For each of the generated functions, length($pref) leading -# letters are already checked. Moreover, it is recommended that -# the generated functions uses switch on letter at offset at least -# $off + length($pref). -# -# The given list has length($pref) chars removed at front, it is -# guarantied that $off leading chars in the rest are the same for all -# elts of the list. -# -# Returns: how at which offset it was decided to make a switch, or -1 if none. - -sub write_const; - -sub write_const { - my ($fh, $pref, $off, $list) = (shift,shift,shift,shift); - my %leading; - my $offarg = length $pref; - - if (@$list == 0) { # Can happen on the initial iteration only - print $fh <<"END"; -static double -constant(char *name, int len, int arg) -{ - errno = EINVAL; - return 0; -} -END - return -1; - } - - if (@$list == 1) { # Can happen on the initial iteration only - my $protect = protect_convert_to_double("$pref$list->[0]"); - - print $fh <<"END"; -static double -constant(char *name, int len, int arg) -{ - errno = 0; - if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */ -#ifdef $pref$list->[0] - return $protect$pref$list->[0]; -#else - errno = ENOENT; - return 0; -#endif - } - errno = EINVAL; - return 0; -} -END - return -1; - } - - for my $n (@$list) { - my $c = substr $n, $off, 1; - $leading{$c} = [] unless exists $leading{$c}; - push @{$leading{$c}}, substr $n, $off + 1; - } - - if (keys(%leading) == 1) { - return 1 + write_const $fh, $pref, $off + 1, $list; - } - - my $leader = substr $list->[0], 0, $off; - foreach my $letter (keys %leading) { - write_const $fh, "$pref$leader$letter", 0, $leading{$letter} - if @{$leading{$letter}} > 1; - } - - my $npref = "_$pref"; - $npref = '' if $pref eq ''; - - print $fh <<"END"; -static double -constant$npref(char *name, int len, int arg) -{ -END - - print $fh <<"END" if $npref eq ''; - errno = 0; -END - - print $fh <<"END" if $off; - if ($offarg + $off >= len ) { - errno = EINVAL; - return 0; - } -END - - print $fh <<"END"; - switch (name[$offarg + $off]) { -END - - foreach my $letter (sort keys %leading) { - my $let = $letter; - $let = '\0' if $letter eq ''; - - print $fh <<EOP; - case '$let': -EOP - if (@{$leading{$letter}} > 1) { - # It makes sense to call a function - if ($off) { - print $fh <<EOP; - if (!strnEQ(name + $offarg,"$leader", $off)) - break; -EOP - } - print $fh <<EOP; - return constant_$pref$leader$letter(name, len, arg); -EOP - } - else { - # Do it ourselves - my $protect - = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]"); - - print $fh <<EOP; - if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */ -#ifdef $pref$leader$letter$leading{$letter}[0] - return $protect$pref$leader$letter$leading{$letter}[0]; -#else - goto not_there; -#endif - } -EOP - } - } - print $fh <<"END"; - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -END - -} - -if( ! $opt_c ) { - print XS <<"END"; -static int -not_here(char *s) -{ - croak("$module::%s not implemented on this architecture", s); - return -1; -} - -END - - write_const(\*XS, '', 0, \@const_names); -} - -print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls; - -my $prefix; -$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(sv,arg) - PREINIT: - STRLEN len; - INPUT: - SV * sv - char * s = SvPV(sv, len); - int arg - CODE: - RETVAL = constant(s,len,arg); - OUTPUT: - RETVAL - -END - -my %seen_decl; -my %typemap; - -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], 1 ) } @$args; - if ($opt_k) { - s/^\s*const\b\s*// for @argtypes; - } - my @argarrays = map { $_->[4] || '' } @$args; - my $numargs = @$args; - if ($numargs and $argtypes[-1] eq '...') { - $numargs--; - $argnames[-1] = '...'; - } - local $" = ', '; - $type = normalize_type($type, 1); - - print $fh <<"EOP"; - -$type -$name(@argnames) -EOP - - for my $arg (0 .. $numargs - 1) { - print $fh <<"EOP"; - $argtypes[$arg] $argnames[$arg]$argarrays[$arg] -EOP - } -} - -sub print_tievar_subs { - my($fh, $name, $type) = @_; - print $fh <<END; -I32 -_get_$name(IV index, SV *sv) { - dSP; - PUSHMARK(SP); - XPUSHs(sv); - PUTBACK; - (void)call_pv("$module\::_get_$name", G_DISCARD); - return (I32)0; -} - -I32 -_set_$name(IV index, SV *sv) { - dSP; - PUSHMARK(SP); - XPUSHs(sv); - PUTBACK; - (void)call_pv("$module\::_set_$name", G_DISCARD); - return (I32)0; -} - -END -} - -sub print_tievar_xsubs { - my($fh, $name, $type) = @_; - print $fh <<END; -void -_tievar_$name(sv) - SV* sv - PREINIT: - struct ufuncs uf; - CODE: - uf.uf_val = &_get_$name; - uf.uf_set = &_set_$name; - uf.uf_index = (IV)&_get_$name; - sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf)); - -void -_get_$name(THIS) - $type THIS = NO_INIT - CODE: - THIS = $name; - OUTPUT: - SETMAGIC: DISABLE - THIS - -void -_set_$name(THIS) - $type THIS - CODE: - $name = THIS; - -END -} - -sub print_accessors { - my($fh, $name, $struct) = @_; - return unless defined $struct && $name !~ /\s|_ANON/; - $name = normalize_type($name); - my $ptrname = normalize_type("$name *"); - print $fh <<"EOF"; - -MODULE = $module PACKAGE = ${name} $prefix - -$name * -_to_ptr(THIS) - $name THIS = NO_INIT - PROTOTYPE: \$ - CODE: - if (sv_derived_from(ST(0), "$name")) { - STRLEN len; - char *s = SvPV((SV*)SvRV(ST(0)), len); - if (len != sizeof(THIS)) - croak("Size \%d of packed data != expected \%d", - len, sizeof(THIS)); - RETVAL = ($name *)s; - } - else - croak("THIS is not of type $name"); - OUTPUT: - RETVAL - -$name -new(CLASS) - char *CLASS = NO_INIT - PROTOTYPE: \$ - CODE: - Zero((void*)&RETVAL, sizeof(RETVAL), char); - OUTPUT: - RETVAL - -MODULE = $module PACKAGE = ${name}Ptr $prefix - -EOF - my @items = @$struct; - while (@items) { - my $item = shift @items; - if ($item->[0] =~ /_ANON/) { - if (defined $item->[2]) { - push @items, map [ - @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", - ], @{ $structs{$item->[0]} }; - } else { - push @items, @{ $structs{$item->[0]} }; - } - } else { - my $type = normalize_type($item->[0]); - my $ttype = $structs{$type} ? normalize_type("$type *") : $type; - print $fh <<"EOF"; -$ttype -$item->[2](THIS, __value = NO_INIT) - $ptrname THIS - $type __value - PROTOTYPE: \$;\$ - CODE: - if (items > 1) - THIS->$item->[-1] = __value; - RETVAL = @{[ - $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])" - ]}; - OUTPUT: - RETVAL - -EOF - } - } -} - -sub accessor_docs { - my($name, $struct) = @_; - return unless defined $struct && $name !~ /\s|_ANON/; - $name = normalize_type($name); - my $ptrname = $name . 'Ptr'; - my @items = @$struct; - my @list; - while (@items) { - my $item = shift @items; - if ($item->[0] =~ /_ANON/) { - if (defined $item->[2]) { - push @items, map [ - @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", - ], @{ $structs{$item->[0]} }; - } else { - push @items, @{ $structs{$item->[0]} }; - } - } else { - push @list, $item->[2]; - } - } - my $methods = (join '(...)>, C<', @list) . '(...)'; - - my $pod = <<"EOF"; -# -#=head2 Object and class methods for C<$name>/C<$ptrname> -# -#The principal Perl representation of a C object of type C<$name> is an -#object of class C<$ptrname> which is a reference to an integer -#representation of a C pointer. To create such an object, one may use -#a combination -# -# my \$buffer = $name->new(); -# my \$obj = \$buffer->_to_ptr(); -# -#This exersizes the following two methods, and an additional class -#C<$name>, the internal representation of which is a reference to a -#packed string with the C structure. Keep in mind that \$buffer should -#better survive longer than \$obj. -# -#=over -# -#=item C<\$object_of_type_$name-E<gt>_to_ptr()> -# -#Converts an object of type C<$name> to an object of type C<$ptrname>. -# -#=item C<$name-E<gt>new()> -# -#Creates an empty object of type C<$name>. The corresponding packed -#string is zeroed out. -# -#=item C<$methods> -# -#return the current value of the corresponding element if called -#without additional arguments. Set the element to the supplied value -#(and return the new value) if called with an additional argument. -# -#Applicable to objects of type C<$ptrname>. -# -#=back -# -EOF - $pod =~ s/^\#//gm; - return $pod; -} - -# 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('\$%&*@;') . "]" ; - - # Start with useful default values - $typemap{float} = 'T_DOUBLE'; - - foreach my $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*($|\#)/ ; - my ($type, $image); - 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)) { - $typemap{normalize_type($type)} = $image; - } - } - } - close(TYPEMAP) or die "Cannot close $typemap: $!"; - } - %std_types = %types_seen; - %types_seen = (); -} - - -sub normalize_type { # Second arg: do not strip const's before \* - my $type = shift; - my $do_keep_deep_const = shift; - # If $do_keep_deep_const this is heuristical only - my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); - my $ignore_mods - = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*"; - if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately! - $type =~ s/$ignore_mods//go; - } - else { - $type =~ s/$ignore_mods//go; - } - $type =~ s/([^\s\w])/ \1 /g; - $type =~ s/\s+$//; - $type =~ s/^\s+//; - $type =~ s/\s+/ /g; - $type =~ s/\* (?=\*)/*/g; - $type =~ s/\. \. \./.../g; - $type =~ s/ ,/,/g; - $types_seen{$type}++ - unless $type eq '...' or $type eq 'void' or $std_types{$type}; - $type; -} - -my $need_opaque; - -sub assign_typemap_entry { - my $type = shift; - my $otype = $type; - my $entry; - if ($tmask and $type =~ /$tmask/) { - print "Type $type matches -o mask\n" if $opt_d; - $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); - } - elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { - $type = normalize_type $type; - print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d; - $entry = assign_typemap_entry($type); - } - $entry ||= $typemap{$otype} - || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); - $typemap{$otype} = $entry; - $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT"; - return $entry; -} - -for (@vdecls) { - print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_}); -} - -if ($opt_x) { - for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } - if ($opt_a) { - while (my($name, $struct) = each %structs) { - print_accessors(\*XS, $name, $struct); - } - } -} - -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 (sort keys %types_seen) { - my $entry = assign_typemap_entry $type; - print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n" - } - - print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry -############################################################################# -INPUT -T_OPAQUE_STRUCT - if (sv_derived_from($arg, \"${ntype}\")) { - STRLEN len; - char *s = SvPV((SV*)SvRV($arg), len); - - if (len != sizeof($var)) - croak(\"Size %d of packed data != expected %d\", - len, sizeof($var)); - $var = *($type *)s; - } - else - croak(\"$var is not of type ${ntype}\") -############################################################################# -OUTPUT -T_OPAQUE_STRUCT - sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var)); -EOP - - 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. -WriteMakefile( - 'NAME' => '$module', - 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION - 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 - (\$] >= 5.005 ? ## Add these new keywords supported since 5.005 - (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module - AUTHOR => '$author <$email>') : ()), -END -if (!$opt_X) { # print C stuff, unless XS is disabled - $opt_F = '' unless defined $opt_F; - my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : ''); - my $Ihelp = ($I ? '-I. ' : ''); - my $Icomment = ($I ? '' : <<EOC); - # Insert -I. if you add *.h files later: -EOC - - print PL <<END; - 'LIBS' => ['$extralibs'], # e.g., '-lm' - 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING' -$Icomment 'INC' => '$I', # e.g., '$Ihelp-I/usr/include/other' -END - - my $C = grep $_ ne "$modfname.c", (glob '*.c'), (glob '*.cc'), (glob '*.C'); - my $Cpre = ($C ? '' : '# '); - my $Ccomment = ($C ? '' : <<EOC); - # Un-comment this if you add C files to link with later: -EOC - - print PL <<END; -$Ccomment $Cpre\'OBJECT' => '\$(O_FILES)', # link all the C files too -END -} -print PL ");\n"; -close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; - -# Create a simple README since this is a CPAN requirement -# and it doesnt hurt to have one -warn "Writing $ext$modpname/README\n"; -open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n"; -my $thisyear = (gmtime)[5] + 1900; -my $rmhead = "$modpname version $TEMPLATE_VERSION"; -my $rmheadeq = "=" x length($rmhead); -print RM <<_RMEND_; -$rmhead -$rmheadeq - -The README is used to introduce the module and provide instructions on -how to install the module, any machine dependencies it may have (for -example C compilers and installed libraries) and any other information -that should be provided before the module is installed. - -A README file is required for CPAN modules since CPAN extracts the -README file from a module distribution so that people browsing the -archive can use it get an idea of the modules uses. It is usually a -good idea to provide version information here so that people can -decide whether fixes for the module are worth downloading. - -INSTALLATION - -To install this module type the following: - - perl Makefile.PL - make - make test - make install - -DEPENDENCIES - -This module requires these other modules and libraries: - - blah blah blah - -COPYRIGHT AND LICENCE - -Put the correct copyright and licence information here. - -Copyright (C) $thisyear $author blah blah blah - -_RMEND_ -close(RM) || die "Can't close $ext$modpname/README: $!\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' - -######################### - -# change 'tests => 1' to 'tests => last_test_to_print'; - -use Test; -BEGIN { plan tests => 1 }; -_END_ -print EX <<_END_; -use $module; -_END_ -print EX <<'_END_'; -ok(1); # If we made it this far, we're ok. - -######################### - -# Insert your test code below, the Test module is use()ed here so read -# its man page ( perldoc Test ) for help writing this test script. - -_END_ -close(EX) || die "Can't close $ext$modpname/test.pl: $!\n"; - -unless ($opt_C) { - warn "Writing $ext$modpname/Changes\n"; - $" = ' '; - open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; - @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS; - print EX <<EOP; -Revision history for Perl extension $module. - -$TEMPLATE_VERSION @{[scalar localtime]} -\t- original version; created by h2xs $H2XS_VERSION with options -\t\t@ARGS - -EOP - 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: $!"; -my @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 deleted file mode 100644 index 8a4a8dc..0000000 --- a/contrib/perl5/utils/perlbug.PL +++ /dev/null @@ -1,1224 +0,0 @@ -#!/usr/local/bin/perl -# $FreeBSD$ - -use Config; -use File::Basename qw(&basename &dirname); -use Cwd; -use File::Spec::Functions; - -# 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, "<" . catfile(updir, "patchlevel.h") or 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/"?\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) or die "Error closing patchlevel.h: $!"; - -# 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. - -my $extract_version = sprintf("v%vd", $^V); - -print OUT <<"!GROK!THIS!"; -$Config{startperl} - eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; - -my \$config_tag1 = '$extract_version - $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 File::Spec; # keep perlbug Perl 5.005 compatible -use Getopt::Std; -use strict; - -sub paraprint; - -BEGIN { - eval "use Mail::Send;"; - $::HaveSend = ($@ eq ""); - eval "use Mail::Util;"; - $::HaveUtil = ($@ eq ""); -}; - -my $Version = "1.33"; - -# 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 -# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27 -# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000 -# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000 -# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000 -# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000 -# Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000 -# Changed in 1.33 Don't require -t STDOUT for -ok. - -# 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, $Is_MacOS, $category, $severity, - $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); - -my $perl_version = $^V ? sprintf("v%vd", $^V) : $]; - -my $config_tag2 = "$perl_version - $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"; -} - -Query(); -Edit() unless $usefile || ($ok and not $::opt_n); -NowWhat(); -Send(); - -exit; - -sub ask_for_alternatives { # (category|severity) - my $name = shift; - my %alts = ( - 'category' => { - 'default' => 'core', - 'ok' => 'install', - 'opts' => [qw(core docs install library utilities)], # patch, notabug - }, - 'severity' => { - 'default' => 'low', - 'ok' => 'none', - 'opts' => [qw(critical high medium low wishlist none)], # zero - }, - ); - die "Invalid alternative($name) requested\n" unless grep(/^$name$/, keys %alts); - my $alt = ""; - if ($ok) { - $alt = $alts{$name}{'ok'}; - } else { - my @alts = @{$alts{$name}{'opts'}}; - paraprint <<EOF; -Please pick a \u$name from the following: - - @alts - -EOF - my $err = 0; - do { - if ($err++ > 5) { - die "Invalid $name: aborting.\n"; - } - print "Please enter a \u$name [$alts{$name}{'default'}]: "; - $alt = <>; - chomp $alt; - if ($alt =~ /^\s*$/) { - $alt = $alts{$name}{'default'}; - } - } while !((($alt) = grep(/^$alt/i, @alts))); - } - lc $alt; -} - -sub Init { - # -------- Setup -------- - - $Is_MSWin32 = $^O eq 'MSWin32'; - $Is_VMS = $^O eq 'VMS'; - $Is_MacOS = $^O eq 'MacOS'; - - @ARGV = split m/\s+/, - MacPerl::Ask('Provide command-line args here (-h for help):') - if $Is_MacOS && $MacPerl::Version =~ /App/; - - if (!getopts("Adhva: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.org'; - - # 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") - || ($Is_MacOS && '') - || "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 $perl_version ${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'} - : $Is_MacOS ? $ENV{'USER'} - : 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'} || ''; - if ($Is_MacOS) { - require Mac::InternetConfig; - $guess = $Mac::InternetConfig::InternetConfig{ - Mac::InternetConfig::kICEmail() - }; - } - - 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; - } - } - - # Prompt for category of bug - $category ||= ask_for_alternatives('category'); - - # Prompt for severity of bug - $severity ||= ask_for_alternatives('severity'); - - # 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") or die "Unable to create report file `$filename': $!\n"; - 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 $perl_version. - -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) or die "Error closing `$file': $!"; - } else { - print REP <<EOF; - ------------------------------------------------------------------ -[Please enter your report here] - - - -[Please do not change anything below this line] ------------------------------------------------------------------ -EOF - } - Dump(*REP); - close(REP) or die "Error closing report file: $!"; - - # 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") or die "Unable to open report file `$filename': $!\n"; - while (<REP>) { - s/\s+//g; - $REP{$_}++; - } - close(REP) or die "Error closing report file `$filename': $!"; -} # sub Query - -sub Dump { - local(*OUT) = @_; - - print OUT <<EFF; ---- -Flags: - category=$category - severity=$severity -EFF - if ($::opt_A) { - print OUT <<EFF; - ack=no -EFF - } - print OUT <<EFF; ---- -EFF - print OUT "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 $perl_version: - -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 $perl_version: -EOF - for my $i (@INC) { - print OUT " $i\n"; - } - - print OUT <<EOF; - ---- -Environment for perl $perl_version: -EOF - my @env = - qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE); - push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne ''; - push @env, grep /^(?:PERL|LC_|LANG)/, keys %ENV; - my %env; - @env{@env} = @env; - for my $env (sort keys %env) { - print OUT " $env", - exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', - "\n"; - } - if ($verbose) { - print OUT "\nComplete configuration data for perl $perl_version:\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; - $sts = system("$ed $filename") unless $Is_MacOS; - if ($Is_MacOS) { - require ExtUtils::MakeMaker; - ExtUtils::MM_MacOS::launch_file($filename); - paraprint <<EOF; -Press Enter when done. -EOF - scalar <>; - } - 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") or die "Couldn't open `$filename': $!\n"; - # 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") or die "Couldn't open file `$filename': $!\n"; - 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) or die "Error closing report file `$filename': $!"; - close(FILE) or die "Error closing $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") or die "Couldn't open file `$filename': $!\n"; - while (<REP>) { print $_ } - close(REP) or die "Error closing report file `$filename': $!"; - } 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/i) { - 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") or die "Couldn't open `$filename': $!\n"; - while (<REP>) { print $fh $_ } - close(REP) or die "Error closing $filename: $!"; - $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 -oi") || die "'|$sendmail -t -oi' 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") or die "Couldn't open `$filename': $!\n"; - while (<REP>) { print SENDMAIL $_ } - close(REP) or die "Error closing $filename: $!"; - - 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] [-A] [-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. This prints out your configuration data, without mailing - anything. You can use this with -v to get more complete data. - -A Don't send a bug received acknowledgement to the return address. - -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 = File::Spec->tmpdir(); - $filename = "bugrep0$$"; - $filename++ while -e File::Spec->catfile($dir, $filename); - $filename = File::Spec->catfile($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<-A> ]> S<[ B<-h> ]> - -B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> - S<[ B<-A> ]> 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.org>. 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>. - -Check in L<perldiag> to see what any Perl error message(s) mean. -If message isn't in perldiag, it probably isn't generated by Perl. -Consult your operating system documentation instead. - -If you are on a non-UNIX platform check also L<perlport>, as some -features may be unimplemented or work differently. - -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. - -Remember also to include the B<exact> error messages, if any. -"Perl complained something" is not an exact error message. - -If you get a core dump (or equivalent), you may use a debugger -(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug -report. NOTE: unless your Perl has been compiled with debug info -(often B<-g>), the stack trace is likely to be somewhat hard to use -because it will most probably contain only the function names and not -their arguments. If possible, recompile your Perl with debug info and -reproduce the dump and the stack trace. - -=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 analyze the -problem (to the extent you can) 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.org 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.org>. 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). - -Whether you use C<perlbug> or send the email manually, please make -your Subject line informative. "a bug" not informative. Neither is -"perl crashes" nor "HELP!!!". These don't help. -A compact description of what's wrong is fine. - -=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.org'. - -=item B<-A> - -Don't send a bug received acknowledgement to the reply address. -Generally it is only a sensible to use this option if you are a -perl maintainer actively watching perl porters for your message to -arrive. - -=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@activestate.comE<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>), -Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>), -Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor -(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>, -and Richard Foley (E<lt>richard@rfi.netE<gt>). - -=head1 SEE ALSO - -perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1), -diff(1), patch(1), dbx(1), gdb(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 deleted file mode 100644 index 6304555..0000000 --- a/contrib/perl5/utils/perlcc.PL +++ /dev/null @@ -1,667 +0,0 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); -use File::Spec; -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; ---\$running_under_some_shell; -!GROK!THIS! - -# In the following, perl variables are not expanded during extraction. - -print OUT <<'!NO!SUBS!'; - -# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000 -# Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000 -# Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000 -# Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001 - -use strict; -use warnings; -use v5.6.0; - -use FileHandle; -use Config; -use Fcntl qw(:DEFAULT :flock); -use File::Temp qw(tempfile); -use Cwd; -our $VERSION = 2.03; -$| = 1; - -$SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves. - -use subs qw{ - cc_harness check_read check_write checkopts_byte choose_backend - compile_byte compile_cstyle compile_module generate_code - grab_stash parse_argv sanity_check vprint yclept spawnit -}; -sub opt(*); # imal quoting - -our ($Options, $BinPerl, $Backend); -our ($Input => $Output); -our ($logfh); -our ($cfile); - -# eval { main(); 1 } or die; - -main(); - -sub main { - parse_argv(); - check_write($Output); - choose_backend(); - generate_code(); - run_code(); - _die("XXX: Not reached?"); -} - -####################################################################### - -sub choose_backend { - # Choose the backend. - $Backend = 'C'; - if (opt(B)) { - checkopts_byte(); - $Backend = 'Bytecode'; - } - if (opt(S) && opt(c)) { - # die "$0: Do you want me to compile this or not?\n"; - delete $Options->{S}; - } - $Backend = 'CC' if opt(O); -} - - -sub generate_code { - - vprint 0, "Compiling $Input"; - - $BinPerl = yclept(); # Calling convention for perl. - - if (opt(shared)) { - compile_module(); - } else { - if ($Backend eq 'Bytecode') { - compile_byte(); - } else { - compile_cstyle(); - } - } - exit(0) if (!opt('r')); -} - -sub run_code { - vprint 0, "Running code"; - run("$Output @ARGV"); - exit(0); -} - -# usage: vprint [level] msg args -sub vprint { - my $level; - if (@_ == 1) { - $level = 1; - } elsif ($_[0] =~ /^\d$/) { - $level = shift; - } else { - # well, they forgot to use a number; means >0 - $level = 0; - } - my $msg = "@_"; - $msg .= "\n" unless substr($msg, -1) eq "\n"; - if (opt(v) > $level) - { - print "$0: $msg" if !opt('log'); - print $logfh "$0: $msg" if opt('log'); - } -} - -sub parse_argv { - - use Getopt::Long; -# Getopt::Long::Configure("bundling"); turned off. this is silly because -# it doesn't allow for long switches. - Getopt::Long::Configure("no_ignore_case"); - - # no difference in exists and defined for %ENV; also, a "0" - # argument or a "" would not help cc, so skip - unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS}; - - $Options = {}; - Getopt::Long::GetOptions( $Options, - 'L:s', # lib directory - 'I:s', # include directories (FOR C, NOT FOR PERL) - 'o:s', # Output executable - 'v:i', # Verbosity level - 'e:s', # One-liner - 'r', # run resulting executable - 'B', # Byte compiler backend - 'O', # Optimised C backend - 'c', # Compile only - 'h', # Help me - 'S', # Dump C files - 'r', # run the resulting executable - 'static', # Dirty hack to enable -shared/-static - 'shared', # Create a shared library (--shared for compat.) - 'log:s' # where to log compilation process information - ); - - # This is an attempt to make perlcc's arg. handling look like cc. - # if ( opt('s') ) { # must quote: looks like s)foo)bar)! - # if (opt('s') eq 'hared') { - # $Options->{shared}++; - # } elsif (opt('s') eq 'tatic') { - # $Options->{static}++; - # } else { - # warn "$0: Unknown option -s", opt('s'); - # } - # } - - $Options->{v} += 0; - - helpme() if opt(h); # And exit - - $Output = opt(o) || 'a.out'; - $Output = relativize($Output); - $logfh = new FileHandle(">> " . opt('log')) if (opt('log')); - - if (opt(e)) { - warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV; - # We don't use a temporary file here; why bother? - # XXX: this is not bullet proof -- spaces or quotes in name! - $Input = "-e '".opt(e)."'"; # Quotes eaten by shell - } else { - $Input = shift @ARGV; # XXX: more files? - _usage_and_die("$0: No input file specified\n") unless $Input; - # DWIM modules. This is bad but necessary. - $Options->{shared}++ if $Input =~ /\.pm\z/; - warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV; - check_read($Input); - check_perl($Input); - sanity_check(); - } - -} - -sub opt(*) { - my $opt = shift; - return exists($Options->{$opt}) && ($Options->{$opt} || 0); -} - -sub compile_module { - die "$0: Compiling to shared libraries is currently disabled\n"; -} - -sub compile_byte { - require ByteLoader; - my $stash = grab_stash(); - my $command = "$BinPerl -MO=Bytecode,$stash $Input"; - # The -a option means we'd have to close the file and lose the - # lock, which would create the tiniest of races. Instead, append - # the output ourselves. - vprint 1, "Writing on $Output"; - - my $openflags = O_WRONLY | O_CREAT; - $openflags |= O_BINARY if eval { O_BINARY; 1 }; - $openflags |= O_EXLOCK if eval { O_EXLOCK; 1 }; - - # these dies are not "$0: .... \n" because they "can't happen" - - sysopen(OUT, $Output, $openflags) - or die "can't write to $Output: $!"; - - # this is blocking; hold on; why are we doing this?? - # flock OUT, LOCK_EX or die "can't lock $Output: $!" - # unless eval { O_EXLOCK; 1 }; - - truncate(OUT, 0) - or die "couldn't trunc $Output: $!"; - - print OUT <<EOF; -#!$^X -use ByteLoader $ByteLoader::VERSION; -EOF - - # Now the compile: - vprint 1, "Compiling..."; - vprint 3, "Calling $command"; - - my ($output_r, $error_r) = spawnit($command); - - if (@$error_r && $? != 0) { - _die("$0: $Input did not compile, which can't happen:\n@$error_r\n"); - } else { - my @error = grep { !/^$Input syntax OK$/o } @$error_r; - warn "$0: Unexpected compiler output:\n@error" if @error; - } - - # Write it and leave. - print OUT @$output_r or _die("can't write $Output: $!"); - close OUT or _die("can't close $Output: $!"); - - # wait, how could it be anything but what you see next? - chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!"); - exit 0; -} - -sub compile_cstyle { - my $stash = grab_stash(); - - # What are we going to call our output C file? - my $lose = 0; - my ($cfh); - - if (opt(S) || opt(c)) { - # We need to keep it. - if (opt(e)) { - $cfile = "a.out.c"; - } else { - $cfile = $Input; - # File off extension if present - # hold on: plx is executable; also, careful of ordering! - $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i; - $cfile .= ".c"; - $cfile = $Output if opt(c) && $Output =~ /\.c\z/i; - } - check_write($cfile); - } else { - # Don't need to keep it, be safe with a tempfile. - $lose = 1; - ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c"); - close $cfh; # See comment just below - } - vprint 1, "Writing C on $cfile"; - - my $max_line_len = ''; - if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) { - $max_line_len = '-l2000,'; - } - - # This has to do the write itself, so we can't keep a lock. Life - # sucks. - my $command = "$BinPerl -MO=$Backend,$max_line_len$stash,-o$cfile $Input"; - vprint 1, "Compiling..."; - vprint 1, "Calling $command"; - - my ($output_r, $error_r) = spawnit($command); - my @output = @$output_r; - my @error = @$error_r; - - if (@error && $? != 0) { - _die("$0: $Input did not compile, which can't happen:\n@error\n"); - } - - cc_harness($cfile,$stash) unless opt(c); - - if ($lose) { - vprint 2, "unlinking $cfile"; - unlink $cfile or _die("can't unlink $cfile: $!"); - } -} - -sub cc_harness { - my ($cfile,$stash)=@_; - use ExtUtils::Embed (); - my $command = ExtUtils::Embed::ccopts." -o $Output $cfile "; - $command .= " -I".$_ for split /\s+/, opt(I); - $command .= " -L".$_ for split /\s+/, opt(L); - my @mods = split /-?u /, $stash; - $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods); - vprint 3, "running $Config{cc} $command"; - system("$Config{cc} $command"); -} - -# Where Perl is, and which include path to give it. -sub yclept { - my $command = "$^X "; - - # DWIM the -I to be Perl, not C, include directories. - if (opt(I) && $Backend eq "Bytecode") { - for (split /\s+/, opt(I)) { - if (-d $_) { - push @INC, $_; - } else { - warn "$0: Include directory $_ not found, skipping\n"; - } - } - } - - $command .= "-I$_ " for @INC; - return $command; -} - -# Use B::Stash to find additional modules and stuff. -{ - my $_stash; - sub grab_stash { - - warn "already called get_stash once" if $_stash; - - my $command = "$BinPerl -MB::Stash -c $Input"; - # Filename here is perfectly sanitised. - vprint 3, "Calling $command\n"; - - my ($stash_r, $error_r) = spawnit($command); - my @stash = @$stash_r; - my @error = @$error_r; - - if (@error && $? != 0) { - _die("$0: $Input did not compile:\n@error\n"); - } - - $stash[0] =~ s/,-u\<none\>//; - vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0]; - chomp $stash[0]; - return $_stash = $stash[0]; - } - -} - -# Check the consistency of options if -B is selected. -# To wit, (-B|-O) ==> no -shared, no -S, no -c -sub checkopts_byte { - - _die("$0: Please choose one of either -B and -O.\n") if opt(O); - - if (opt(shared)) { - warn "$0: Will not create a shared library for bytecode\n"; - delete $Options->{shared}; - } - - for my $o ( qw[c S] ) { - if (opt($o)) { - warn "$0: Compiling to bytecode is a one-pass process--", - "-$o ignored\n"; - delete $Options->{$o}; - } - } - -} - -# Check the input and output files make sense, are read/writeable. -sub sanity_check { - if ($Input eq $Output) { - if ($Input eq 'a.out') { - _die("$0: Compiling a.out is probably not what you want to do.\n"); - # You fully deserve what you get now. No you *don't*. typos happen. - } else { - warn "$0: Will not write output on top of input file, ", - "compiling to a.out instead\n"; - $Output = "a.out"; - } - } -} - -sub check_read { - my $file = shift; - unless (-r $file) { - _die("$0: Input file $file is a directory, not a file\n") if -d _; - unless (-e _) { - _die("$0: Input file $file was not found\n"); - } else { - _die("$0: Cannot read input file $file: $!\n"); - } - } - unless (-f _) { - # XXX: die? don't try this on /dev/tty - warn "$0: WARNING: input $file is not a plain file\n"; - } -} - -sub check_write { - my $file = shift; - if (-d $file) { - _die("$0: Cannot write on $file, is a directory\n"); - } - if (-e _) { - _die("$0: Cannot write on $file: $!\n") unless -w _; - } - unless (-w cwd()) { - _die("$0: Cannot write in this directory: $!\n"); - } -} - -sub check_perl { - my $file = shift; - unless (-T $file) { - warn "$0: Binary `$file' sure doesn't smell like perl source!\n"; - print "Checking file type... "; - system("file", $file); - _die("Please try a perlier file!\n"); - } - - open(my $handle, "<", $file) or _die("XXX: can't open $file: $!"); - local $_ = <$handle>; - if (/^#!/ && !/perl/) { - _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n"); - } - -} - -# File spawning and error collecting -sub spawnit { - my ($command) = shift; - my (@error,@output); - my $errname; - (undef, $errname) = tempfile("pccXXXXX"); - { - open (S_OUT, "$command 2>$errname |") - or _die("$0: Couldn't spawn the compiler.\n"); - @output = <S_OUT>; - } - open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n"); - @error = <S_ERROR>; - close S_ERROR; - close S_OUT; - unlink $errname or _die("$0: Can't unlink error file $errname"); - return (\@output, \@error); -} - -sub helpme { - print "perlcc compiler frontend, version $VERSION\n\n"; - { no warnings; - exec "pod2usage $0"; - exec "perldoc $0"; - exec "pod2text $0"; - } -} - -sub relativize { - my ($args) = @_; - - return() if ($args =~ m"^[/\\]"); - return("./$args"); -} - -sub _die { - $logfh->print(@_) if opt('log'); - print STDERR @_; - exit(); # should die eventually. However, needed so that a 'make compile' - # can compile all the way through to the end for standard dist. -} - -sub _usage_and_die { - _die(<<EOU); -$0: Usage: -$0 [-o executable] [-r] [-O|-B|-c|-S] [-log log] [source[.pl] | -e oneliner] -EOU -} - -sub run { - my (@commands) = @_; - - print interruptrun(@commands) if (!opt('log')); - $logfh->print(interruptrun(@commands)) if (opt('log')); -} - -sub interruptrun -{ - my (@commands) = @_; - - my $command = join('', @commands); - local(*FD); - my $pid = open(FD, "$command |"); - my $text; - - local($SIG{HUP}) = sub { kill 9, $pid; exit }; - local($SIG{INT}) = sub { kill 9, $pid; exit }; - - my $needalarm = - ($ENV{PERLCC_TIMEOUT} && - $Config{'osname'} ne 'MSWin32' && - $command =~ m"(^|\s)perlcc\s"); - - eval - { - local($SIG{ALRM}) = sub { die "INFINITE LOOP"; }; - alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm); - $text = join('', <FD>); - alarm(0) if ($needalarm); - }; - - if ($@) - { - eval { kill 'HUP', $pid }; - vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n"; - } - - close(FD); - return($text); -} - -END { - unlink $cfile if ($cfile && !opt(S) && !opt(c)); -} - -__END__ - -=head1 NAME - -perlcc - generate executables from Perl programs - -=head1 SYNOPSIS - - $ perlcc hello # Compiles into executable 'a.out' - $ perlcc -o hello hello.pl # Compiles into executable 'hello' - - $ perlcc -O file # Compiles using the optimised C backend - $ perlcc -B file # Compiles using the bytecode backend - - $ perlcc -c file # Creates a C file, 'file.c' - $ perlcc -S -o hello file # Creates a C file, 'file.c', - # then compiles it to executable 'hello' - $ perlcc -c out.c file # Creates a C file, 'out.c' from 'file' - - $ perlcc -e 'print q//' # Compiles a one-liner into 'a.out' - $ perlcc -c -e 'print q//' # Creates a C file 'a.out.c' - - $ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'. - - $ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'. - # with arguments 'a b c' - - $ perlcc hello -log c # compiles 'hello' into 'a.out' logs compile - # log into 'c'. - -=head1 DESCRIPTION - -F<perlcc> creates standalone executables from Perl programs, using the -code generators provided by the L<B> module. At present, you may -either create executable Perl bytecode, using the C<-B> option, or -generate and compile C files using the standard and 'optimised' C -backends. - -The code generated in this way is not guaranteed to work. The whole -codegen suite (C<perlcc> included) should be considered B<very> -experimental. Use for production purposes is strongly discouraged. - -=head1 OPTIONS - -=over 4 - -=item -LI<library directories> - -Adds the given directories to the library search path when C code is -passed to your C compiler. - -=item -II<include directories> - -Adds the given directories to the include file search path when C code is -passed to your C compiler; when using the Perl bytecode option, adds the -given directories to Perl's include path. - -=item -o I<output file name> - -Specifies the file name for the final compiled executable. - -=item -c I<C file name> - -Create C code only; do not compile to a standalone binary. - -=item -e I<perl code> - -Compile a one-liner, much the same as C<perl -e '...'> - -=item -S - -Do not delete generated C code after compilation. - -=item -B - -Use the Perl bytecode code generator. - -=item -O - -Use the 'optimised' C code generator. This is more experimental than -everything else put together, and the code created is not guaranteed to -compile in finite time and memory, or indeed, at all. - -=item -v - -Increase verbosity of output; can be repeated for more verbose output. - -=item -r - -Run the resulting compiled script after compiling it. - -=item -log - -Log the output of compiling to a file rather than to stdout. - -=back - -=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 deleted file mode 100644 index cfb773e..0000000 --- a/contrib/perl5/utils/perldoc.PL +++ /dev/null @@ -1,875 +0,0 @@ -#!/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 warnings; -use strict; - -# make sure creat()s are neither too much nor too little -INIT { eval { umask(0077) } } # doubtless someone has no mask - -(my \$pager = <<'/../') =~ s/\\s*\\z//; -$Config{pager} -/../ -my \@pagers = (); -push \@pagers, \$pager if -x \$pager; - -(my \$bindir = <<'/../') =~ s/\\s*\\z//; -$Config{scriptdir} -/../ - -!GROK!THIS! - -# In the following, perl variables are not expanded during extraction. - -print OUT <<'!NO!SUBS!'; - -use Fcntl; # for sysopen -use Getopt::Std; -use Config '%Config'; -use File::Spec::Functions qw(catfile splitdir); - -# -# 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 Christiansen'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. -# -# Massive security and correctness patches applied to this -# noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000 - -if (@ARGV<1) { - my $me = $0; # Editing $0 is unportable - $me =~ s,.*/,,; - die <<EOF; -Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName - $me -f PerlFunc - $me -q FAQKeywords - -The -h option prints more help. Also try "perldoc perldoc" to get -acquainted with the system. -EOF -} - -my @global_found = (); -my $global_target = ""; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $Is_Dos = $^O eq 'dos'; -my $Is_OS2 = $^O eq 'os2'; - -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 - -n Specify replacement for nroff - -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}) - -q Search the text of questions (not answers) in perlfaq[1-9] - -U Run in insecure mode (superuser only) - -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:n:U"; -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; - -# refuse to run if we should be tainting and aren't -# (but regular users deserve protection too, though!) -if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0) - && !am_taint_checking()) -{{ - if ($opt_U) { - my $id = eval { getpwnam("nobody") }; - $id = eval { getpwnam("nouser") } unless defined $id; - $id = -2 unless defined $id; - eval { - $> = $id; # must do this one first! - $< = $id; - }; - last if !$@ && $< && $>; - } - die "Superuser must not run $0 without security audit and taint checks.\n"; -}} - -$opt_n = "nroff" if !$opt_n; - -my $podidx; -if ($opt_X) { - $podidx = "$Config{'archlib'}/pod.idx"; - $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; -} - -if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { - usage("only one of -t, -u, -m or -l") -} -elsif ($Is_MSWin32 - || $Is_Dos - || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i)) -{ - $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 to @INC (if they exist) - eval q{ use lib qw(. lib); 1; } or die; - - # don't add if superuser - if ($< && $> && -f "blib") { # don't be looking too hard now! - eval q{ use blib; 1 }; - warn $@ if $@ && $opt_v; - } -} - -sub containspod { - my($file, $readit) = @_; - return 1 if !$readit && $file =~ /\.pod\z/i; - local($_); - open(TEST,"<", $file) or die "Can't open $file: $!"; - while (<TEST>) { - if (/^=head/) { - close(TEST) or die "Can't close $file: $!"; - return 1; - } - } - close(TEST) or die "Can't close $file: $!"; - return 0; -} - -sub minus_f_nocase { - my($dir,$file) = @_; - my $path = catfile($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 $path: unreadable\n" if -f _; - return ''; - } - local *DIR; - # this is completely wicked. don't mess with $", and if - # you do, don't assume / is the dirsep! - local($")="/"; - my @p = ($dir); - my($p,$cip); - foreach $p (splitdir $file){ - my $try = catfile @p, $p; - stat $try; - if (-d _) { - push @p, $p; - if ( $p eq $global_target) { - my $tmp_path = catfile @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"; - } - elsif (-d "@p") { - my $found=0; - my $lcp = lc $p; - opendir DIR, "@p" or die "opendir @p: $!"; - while ($cip=readdir(DIR)) { - if (lc $cip eq $lcp){ - $found++; - last; - } - } - closedir DIR or die "closedir @p: $!"; - return "" unless $found; - push @p, $cip; - return "@p" if -f "@p" and -r _; - warn "Ignored @p: unreadable\n" if -f _; - } - } - return ""; -} - - -sub check_file { - my($dir,$file) = @_; - return "" if length $dir and not -d $dir; - 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 = (splitdir $s)[-1]; # XXX: why not use File::Basename? - for ($i=0; $i<@dirs; $i++) { - $dir = $dirs[$i]; - ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! 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) - or ( $ret = check_file "$dir/pods","$s.pod") - or ( $ret = check_file "$dir/pods",$s) - ) { - return $ret; - } - - if ($recurse) { - opendir(D,$dir) or die "Can't opendir $dir: $!"; - my @newdirs = map catfile($dir, $_), grep { - not /^\.\.?\z/s and - not /^auto\z/s and # save time! don't search auto dirs - -d catfile($dir, $_) - } readdir D; - closedir(D) or die "Can't closedir $dir: $!"; - next unless @newdirs; - # what a wicked map! - @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS; - print STDERR "Also looking in @newdirs\n" if $opt_v; - push(@dirs,@newdirs); - } - } - return (); -} - -sub filter_nroff { - my @data = split /\n{2,}/, shift; - shift @data while @data and $data[0] !~ /\S/; # Go to header - shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header - pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like - # 28/Jan/99 perl 5.005, patch 53 1 - join "\n\n", @data; -} - -sub printout { - my ($file, $tmp, $filter) = @_; - my $err; - - if ($opt_t) { - # why was this append? - sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) - or die ("Can't open $tmp: $!"); - Pod::Text->new()->parse_from_file($file,\*OUT); - close OUT or die "can't close $tmp: $!"; - } - elsif (not $opt_u) { - my $cmd = catfile($bindir, 'pod2man') . " --lax $file | $opt_n -man"; - $cmd .= " | col -x" if $^O =~ /hpux/; - my $rslt = `$cmd`; - $rslt = filter_nroff($rslt) if $filter; - unless (($err = $?)) { - # why was this append? - sysopen(TMP, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) - or die "Can't open $tmp: $!"; - print TMP $rslt - or die "Can't print $tmp: $!"; - close TMP - or die "Can't close $tmp: $!"; - } - } - if ($opt_u or $err or -z $tmp) { # XXX: race with -z - # why was this append? - sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) - or die "Can't open $tmp: $!"; - open(IN,"<", $file) or die("Can't open $file: $!"); - my $cut = 1; - local $_; - while (<IN>) { - $cut = $1 eq 'cut' if /^=(\w+)/; - next if $cut; - print OUT - or die "Can't print $tmp: $!"; - } - close IN or die "Can't close $file: $!"; - close OUT or die "Can't close $tmp: $!"; - } -} - -sub page { - my ($tmp, $no_tty, @pagers) = @_; - if ($no_tty) { - open(TMP,"<", $tmp) or die "Can't open $tmp: $!"; - local $_; - while (<TMP>) { - print or die "Can't print to stdout: $!"; - } - close TMP or die "Can't close while $tmp: $!"; - } - else { - foreach my $pager (@pagers) { - if ($Is_VMS) { - last if system("$pager $tmp") == 0; # quoting prevents logical expansion - } else { - last if system("$pager \"$tmp\"") == 0; - } - } - } -} - -sub cleanup { - my @files = @_; - for (@files) { - if ($Is_VMS) { - 1 while unlink($_); # XXX: expect failure - } else { - unlink($_); # or die "Can't unlink $_: $!"; - } - } -} - -my @found; -foreach (@pages) { - if ($podidx && open(PODIDX, $podidx)) { - my $searchfor = catfile split '::'; - print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; - local $_; - while (<PODIDX>) { - chomp; - push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; - } - close(PODIDX) or die "Can't close $podidx: $!"; - next; - } - print STDERR "Searching for $_\n" if $opt_v; - # We must look both in @INC for library modules and in $bindir - # for executables, like h2xs or perldoc itself. - my @searchdirs = ($bindir, @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(!/^\.\z/s,@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 "opendir $dir: $!"; - while (my $file = readdir(DIR)) { - next if ($file =~ /^\./s); - $file =~ s/\.(pm|pod)\z//; # XXX: badfs - print STDERR "\tperldoc $_\::$file\n"; - } - closedir DIR or die "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 } -END { close(STDOUT) || die "Can't close STDOUT: $!" } - -# until here we could simply exit or die -# now we create temporary files that we have to clean up -# namely $tmp, $buffer -# that's because you did it wrong, should be descriptor based --tchrist - -my $tmp; -my $buffer; -if ($Is_MSWin32) { - $tmp = "$ENV{TEMP}\\perldoc1.$$"; - $buffer = "$ENV{TEMP}\\perldoc1.b$$"; - push @pagers, qw( more< less notepad ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - for (@found) { s,/,\\,g } -} -elsif ($Is_VMS) { - $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; - $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$; - push @pagers, qw( most more less type/page ); -} -elsif ($Is_Dos) { - $tmp = "$ENV{TEMP}/perldoc1.$$"; - $buffer = "$ENV{TEMP}/perldoc1.b$$"; - $tmp =~ tr!\\/!//!s; - $buffer =~ 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(); - $buffer = POSIX::tmpnam(); - unshift @pagers, 'less', 'cmd /c more <'; - } - else { - # XXX: this is not secure, because it doesn't open it - ($tmp, $buffer) = eval { require POSIX } - ? (POSIX::tmpnam(), POSIX::tmpnam() ) - : ("/tmp/perldoc1.$$", "/tmp/perldoc1.b$$" ); - } - push @pagers, qw( more less pg view cat ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; -} -unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; - -# make sure cleanup called -eval q{ - sub END { cleanup($tmp, $buffer) } - 1; -} || die; - -# exit/die in a windows sighandler is dangerous, so let it do the -# default thing, which is to exit -eval q{ use sigtrap qw(die INT TERM HUP QUIT) } unless $^O eq 'MSWin32'; - -if ($opt_m) { - foreach my $pager (@pagers) { - if (system($pager, @found) == 0) { - exit; - } - } - if ($Is_VMS) { - eval q{ - use vmsish qw(status exit); - exit $?; - 1; - } or die; - } - exit(1); -} - -my @pod; -if ($opt_f) { - my $perlfunc = shift @found; - open(PFUNC, "<", $perlfunc) - or die("Can't open $perlfunc: $!"); - - # Functions like -r, -e, etc. are listed under `-X'. - my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) - ? 'I<-X' : $opt_f ; - - # Skip introduction - local $_; - while (<PFUNC>) { - last if /^=head2 Alphabetical Listing of Perl Functions/; - } - - # Look for our function - my $found = 0; - my $inlist = 0; - while (<PFUNC>) { - if (/^=item\s+\Q$search_string\E\b/o) { - $found = 1; - } - elsif (/^=item/) { - last if $found > 1 and not $inlist; - } - next unless $found; - if (/^=over/) { - ++$inlist; - } - elsif (/^=back/) { - --$inlist; - } - push @pod, $_; - ++$found if /^\w/; # found descriptive text - } - if (!@pod) { - die "No documentation for perl function `$opt_f' found\n"; - } - close PFUNC or die "Can't open $perlfunc: $!"; -} - -if ($opt_q) { - local @ARGV = @found; # I'm lazy, sue me. - my $found = 0; - my %found_in; - my $rx = eval { qr/$opt_q/ } or die <<EOD; -Invalid regular expression '$opt_q' given as -q pattern: - $@ -Did you mean \\Q$opt_q ? - -EOD - - for (@found) { die "invalid file spec: $!" if /[<>|]/ } - local $_; - 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) { - die("No documentation for perl FAQ keyword `$opt_q' found\n"); - } -} - -my $filter; - -if (@pod) { - sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT) - or die("Can't open $buffer: $!"); - print TMP "=over 8\n\n"; - print TMP @pod or die "Can't print $buffer: $!"; - print TMP "=back\n"; - close TMP or die "Can't close $buffer: $!"; - @found = $buffer; - $filter = 1; -} - -foreach (@found) { - printout($_, $tmp, $filter); -} -page($tmp, $no_tty, @pagers); - -exit; - -sub is_tainted { - my $arg = shift; - my $nada = substr($arg, 0, 0); # zero-length - local $@; # preserve caller's version - eval { eval "# $nada" }; - return length($@) != 0; -} - -sub am_taint_checking { - my($k,$v) = each %ENV; - return is_tainted($v); -} - - -__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<-U> run insecurely - -Because B<perldoc> does not run properly tainted, and is known to -have security issues, it will not normally execute as the superuser. -If you use the B<-U> flag, it will do so, but only after setting -the effective and real IDs to nobody's or nouser's account, or -2 -if unavailable. If it cannot relinguish its privileges, it will not -run. - -=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 may 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.) - -One useful value for C<PERLDOC_PAGER> is C<less -+C -E>. - -=head1 VERSION - -This is perldoc v2.03. - -=head1 AUTHOR - -Kenneth Albanowski <kjahds@kjahds.com> - -Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>, -and others. - -=cut - -# -# Version 2.03: Sun Apr 23 16:56:34 BST 2000 -# Hugo van der Sanden <hv@crypt0.demon.co.uk> -# don't die when 'use blib' fails -# Version 2.02: Mon Mar 13 18:03:04 MST 2000 -# Tom Christiansen <tchrist@perl.com> -# Added -U insecurity option -# Version 2.01: Sat Mar 11 15:22:33 MST 2000 -# Tom Christiansen <tchrist@perl.com>, querulously. -# Security and correctness patches. -# What a twisted bit of distasteful spaghetti code. -# Version 2.0: ???? -# Version 1.15: Tue Aug 24 01:50:20 EST 1999 -# Charles Wilson <cwilson@ece.gatech.edu> -# changed /pod/ directory to /pods/ for cygwin -# to support cygwin/win32 -# 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@activestate.com> -# -doc tweaks for -F and -X options -# Version 1.12: Sat Apr 12 22:41:09 EST 1997 -# Gurusamy Sarathy <gsar@activestate.com> -# -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 deleted file mode 100644 index 48e281d..0000000 --- a/contrib/perl5/utils/pl2pm.PL +++ /dev/null @@ -1,389 +0,0 @@ -#!/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 deleted file mode 100644 index 0a71544..0000000 --- a/contrib/perl5/utils/splain.PL +++ /dev/null @@ -1,54 +0,0 @@ -#!/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'; -$in = open IN; -if (!$in) { - $inmsg = "Can't open $IN: $!\n"; - $IN = 'diagnostics.pm'; - $in = open IN or die $inmsg, "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; |
