[Midnightbsd-cvs] src [9594] trunk/contrib/perl/utils: too aggressive.
laffer1 at midnightbsd.org
laffer1 at midnightbsd.org
Sun Oct 1 14:34:40 EDT 2017
Revision: 9594
http://svnweb.midnightbsd.org/src/?rev=9594
Author: laffer1
Date: 2017-10-01 14:34:39 -0400 (Sun, 01 Oct 2017)
Log Message:
-----------
too aggressive.
Added Paths:
-----------
trunk/contrib/perl/utils/
trunk/contrib/perl/utils/Makefile.PL
trunk/contrib/perl/utils/corelist.PL
trunk/contrib/perl/utils/cpan.PL
trunk/contrib/perl/utils/enc2xs.PL
trunk/contrib/perl/utils/encguess.PL
trunk/contrib/perl/utils/h2ph.PL
trunk/contrib/perl/utils/h2xs.PL
trunk/contrib/perl/utils/instmodsh.PL
trunk/contrib/perl/utils/json_pp.PL
trunk/contrib/perl/utils/libnetcfg.PL
trunk/contrib/perl/utils/perlbug.PL
trunk/contrib/perl/utils/perldoc.PL
trunk/contrib/perl/utils/perlivp.PL
trunk/contrib/perl/utils/piconv.PL
trunk/contrib/perl/utils/pl2pm.PL
trunk/contrib/perl/utils/pod2html.PL
trunk/contrib/perl/utils/prove.PL
trunk/contrib/perl/utils/ptar.PL
trunk/contrib/perl/utils/ptardiff.PL
trunk/contrib/perl/utils/ptargrep.PL
trunk/contrib/perl/utils/shasum.PL
trunk/contrib/perl/utils/splain.PL
trunk/contrib/perl/utils/xsubpp.PL
trunk/contrib/perl/utils/zipdetails.PL
Added: trunk/contrib/perl/utils/Makefile.PL
===================================================================
--- trunk/contrib/perl/utils/Makefile.PL (rev 0)
+++ trunk/contrib/perl/utils/Makefile.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,107 @@
+#!./miniperl -w
+use strict;
+use Config;
+
+if (@ARGV) {
+ my $dir = shift;
+ chdir $dir or die "Can't chdir '$dir': $!";
+}
+
+# Note, the generated utils/Makefile isn't used by VMS yet.
+# The next step on cleaning this is up is probably to work to reduce the size
+# of the "problem" in both this file and vms/descrip_mms.template by
+# attempting to move the work from them to the extension directories and
+# ExtUtils::MakeMaker.
+
+require './regen/regen_lib.pl';
+
+my $target = 'utils/Makefile';
+print "Extracting $target (with variable substitutions)\n";
+my $fh = open_new($target, undef, {by => $0}, 1);
+
+# These use the Cwd extension. For statically-built perls, we
+# need perl, not just miniperl.
+my $perl = defined $Config{usedl} ? '../miniperl' : '../perl';
+
+print $fh <<"EOT";
+PERL = $perl
+REALPERL = ../perl
+RUN = # Used mainly cross-compilation setups.
+
+EOT
+
+print $fh <<'EOT';
+
+# Files to be built with variable substitution after miniperl is
+# available. Dependencies handled manually below (for now).
+
+pl = corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL json_pp.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL ptargrep.PL shasum.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL encguess.PL xsubpp.PL pod2html.PL zipdetails.PL
+plextract = corelist cpan h2ph h2xs instmodsh json_pp perlbug perldoc perlivp pl2pm prove ptar ptardiff ptargrep shasum splain libnetcfg piconv enc2xs encguess xsubpp pod2html zipdetails
+plextractexe = ./corelist ./cpan ./h2ph ./h2xs ./json_pp ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./ptargrep ./shasum ./splain ./libnetcfg ./piconv ./enc2xs ./encguess ./xsubpp ./pod2html ./zipdetails
+
+all: $(plextract)
+
+$(plextract):
+ $(RUN) $(PERL) -I../lib $@.PL
+
+cpan: cpan.PL ../config.sh
+
+corelist: corelist.PL ../config.sh
+
+h2ph: h2ph.PL ../config.sh
+
+h2xs: h2xs.PL ../config.sh
+
+instmodsh: instmodsh.PL ../config.sh
+
+json_pp: json_pp.PL ../config.sh
+
+perlbug: perlbug.PL ../config.sh ../patchlevel.h
+
+perldoc: perldoc.PL ../config.sh
+
+perlivp: perlivp.PL ../config.sh
+
+prove: prove.PL ../config.sh
+
+ptar: ptar.PL ../config.sh
+
+ptardiff: ptardiff.PL ../config.sh
+
+ptargrep: ptargrep.PL ../config.sh
+
+pl2pm: pl2pm.PL ../config.sh
+
+shasum: shasum.PL ../config.sh
+
+splain: splain.PL ../config.sh ../lib/diagnostics.pm
+
+libnetcfg: libnetcfg.PL ../config.sh
+
+piconv: piconv.PL ../config.sh
+
+enc2xs: enc2xs.PL ../config.sh
+
+enc2xs: encguess.PL ../config.sh
+
+xsubpp: xsubpp.PL ../config.sh
+
+zipdetails: zipdetails.PL ../config.sh
+
+pod2html: pod2html.PL ../config.sh ../ext/Pod-Html/bin/pod2html
+
+clean:
+
+realclean:
+ rm -rf $(plextract) $(plextractexe)
+ rm -f ../t/_h2ph_pre.ph
+
+clobber: realclean
+
+distclean: clobber
+
+veryclean: distclean
+ -rm -f *~ *.org
+EOT
+
+read_only_bottom_close_and_rename($fh);
Property changes on: trunk/contrib/perl/utils/Makefile.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/corelist.PL
===================================================================
--- trunk/contrib/perl/utils/corelist.PL (rev 0)
+++ trunk/contrib/perl/utils/corelist.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $script = File::Spec->catfile(
+ File::Spec->catdir(
+ File::Spec->updir, qw[dist Module-CoreList]
+ ), "corelist");
+
+if (open(IN, '<', $script)) {
+ print OUT <IN>;
+ close IN;
+} else {
+ die "$0: cannot find '$script'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/corelist.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/cpan.PL
===================================================================
--- trunk/contrib/perl/utils/cpan.PL (rev 0)
+++ trunk/contrib/perl/utils/cpan.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,48 @@
+#!/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!
+
+use File::Spec;
+
+my $cpan = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, qw(cpan CPAN scripts)), "cpan");
+
+if (open(CPAN, '<', $cpan)) {
+ print OUT <CPAN>;
+ close CPAN;
+} else {
+ die "$0: cannot find '$cpan'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/cpan.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/enc2xs.PL
===================================================================
--- trunk/contrib/perl/utils/enc2xs.PL (rev 0)
+++ trunk/contrib/perl/utils/enc2xs.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/usr/local/bin/perl
+
+# Copy the cpan/Encode/bin/enc2xs script to utils/, while
+# prepending a suitable #! invocation.
+
+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!
+
+use File::Spec;
+
+my $enc2xs = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "cpan", "Encode", "bin"), "enc2xs");
+
+if (open(ENC2XS, '<', $enc2xs)) {
+ print OUT <ENC2XS>;
+ close ENC2XS;
+} else {
+ die "$0: cannot find '$enc2xs'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/enc2xs.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/encguess.PL
===================================================================
--- trunk/contrib/perl/utils/encguess.PL (rev 0)
+++ trunk/contrib/perl/utils/encguess.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,48 @@
+#!/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!
+
+use File::Spec;
+
+my $enc2xs = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "cpan", "Encode", "bin"), "encguess");
+
+if (open(ENC2XS, '<', $enc2xs)) {
+ print OUT <ENC2XS>;
+ close ENC2XS;
+} else {
+ die "$0: cannot find '$enc2xs'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/encguess.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/h2ph.PL
===================================================================
--- trunk/contrib/perl/utils/h2ph.PL (rev 0)
+++ trunk/contrib/perl/utils/h2ph.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,1028 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(basename dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+# Wanted: $archlibexp
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT, '>', $file or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
+use strict;
+
+use Config;
+use File::Path qw(mkpath);
+use Getopt::Std;
+
+# Make sure read permissions for all are set:
+if (defined umask && (umask() & 0444)) {
+ umask (umask() & ~0444);
+}
+
+getopts('Dd:rlhaQe');
+use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
+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{installsitearch};
+die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
+ unless -d $Dest_dir;
+
+my @isatype = qw(
+ char uchar u_char
+ short ushort u_short
+ int uint u_int
+ long ulong u_long
+ FILE key_t caddr_t
+ float double size_t
+);
+
+my %isatype;
+ at isatype{@isatype} = (1) x @isatype;
+my $inif = 0;
+my %Is_converted;
+my %bad_file = ();
+
+ at ARGV = ('-') unless @ARGV;
+
+build_preamble_if_necessary();
+
+sub reindent($) {
+ my($text) = shift;
+ $text =~ s/\n/\n /g;
+ $text =~ s/ /\t/g;
+ $text;
+}
+
+my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
+my ($incl, $incl_type, $incl_quote, $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",
+ "no warnings qw(redefine misc);\n\n";
+
+ while (defined (local $_ = next_line($file))) {
+ if (s/^\s*\#\s*//) {
+ if (s/^define\s+(\w+)//) {
+ $name = $1;
+ $new = '';
+ s/\s+$//;
+ s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
+ 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 = "my($args) = \@_;\n$t ";
+ }
+ s/^\s+//;
+ expr();
+ $new =~ s/(["\\])/\\$1/g; #"]);
+ EMIT($proto);
+ } else {
+ s/^\s+//;
+ expr();
+
+ $new = 1 if $new eq '';
+
+ # Shunt around such directives as '#define FOO FOO':
+ next if $new =~ /^\s*&\Q$name\E\s*\z/;
+
+ $new = reindent($new);
+ $args = reindent($args);
+ $new =~ s/(['\\])/\\$1/g; #']);
+
+ print OUT $t, 'eval ';
+ if ($opt_h) {
+ print OUT "\"\\n#line $eval_index $outfile\\n\" . ";
+ $eval_index++;
+ }
+ print OUT "'sub $name () {$new;}' unless defined(&$name);\n";
+ }
+ } elsif (/^(include|import|include_next)\s*([<\"])(.*)[>\"]/) {
+ $incl_type = $1;
+ $incl_quote = $2;
+ $incl = $3;
+ if (($incl_type eq 'include_next') ||
+ ($opt_e && exists($bad_file{$incl}))) {
+ $incl =~ s/\.h$/.ph/;
+ print OUT ($t,
+ "eval {\n");
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT ($t, "my(\@REM);\n");
+ if ($incl_type eq 'include_next') {
+ print OUT ($t,
+ "my(\%INCD) = map { \$INC{\$_} => 1 } ",
+ "(grep { \$_ eq \"$incl\" } ",
+ "keys(\%INC));\n");
+ print OUT ($t,
+ "\@REM = map { \"\$_/$incl\" } ",
+ "(grep { not exists(\$INCD{\"\$_/$incl\"})",
+ " and -f \"\$_/$incl\" } \@INC);\n");
+ } else {
+ print OUT ($t,
+ "\@REM = map { \"\$_/$incl\" } ",
+ "(grep {-r \"\$_/$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");
+ } else {
+ $incl =~ s/\.h$/.ph/;
+ # copy the prefix in the quote syntax (#include "x.h") case
+ if ($incl !~ m|/| && $incl_quote eq q{"} && $file =~ m|^(.*)/|) {
+ $incl = "$1/$incl";
+ }
+ print OUT $t,"require '$incl';\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*)?/) { # { for vi
+ until(/\{[^}]*\}.*;/ || /;/) {
+ last unless defined ($next = next_line($file));
+ chomp $next;
+ # drop "#define FOO FOO" in enums
+ $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
+ # #defines in enums (aliases)
+ $next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/;
+ $_ .= $next;
+ print OUT "# $next\n" if $opt_D;
+ }
+ s/#\s*if.*?#\s*endif//g; # drop #ifdefs
+ s@/\*.*?\*/@@g;
+ s/\s+/ /g;
+ next unless /^\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_name or next;
+ $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");
+ }
+ }
+ } elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/
+ and !/;\s*$/ and !/{\s*}\s*$/)
+ { # { for vi
+ # This is a hack to parse the inline functions in the glibc headers.
+ # Warning: massive kludge ahead. We suppose inline functions
+ # are mainly constructed like macros.
+ while (1) {
+ last unless defined ($next = next_line($file));
+ chomp $next;
+ undef $_, last if $next =~ /__THROW\s*;/
+ or $next =~ /^(__extension__|extern|static)\b/;
+ $_ .= " $next";
+ print OUT "# $next\n" if $opt_D;
+ last if $next =~ /^}|^{.*}\s*$/;
+ }
+ next if not defined; # because it's only a prototype
+ s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g;
+ # violently drop #ifdefs
+ s/#\s*if.*?#\s*endif//g
+ and print OUT "# some #ifdef were dropped here -- fill in the blanks\n";
+ if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) {
+ $name = $1;
+ } else {
+ warn "name not found"; next; # shouldn't occur...
+ }
+ my @args;
+ if (s/^\(([^()]*)\)\s*(\w+\s*)*//) {
+ for my $arg (split /,/, $1) {
+ if ($arg =~ /(\w+)\s*$/) {
+ $curargs{$1} = 1;
+ push @args, $1;
+ }
+ }
+ }
+ $args = (
+ @args
+ ? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t "
+ : ""
+ );
+ my $proto = @args ? '' : '() ';
+ $new = '';
+ s/\breturn\b//g; # "return" doesn't occur in macros usually...
+ expr();
+ # try to find and perlify local C variables
+ our @local_variables = (); # needs to be a our(): (?{...}) bug workaround
+ {
+ use re "eval";
+ my $typelist = join '|', keys %isatype;
+ $new =~ s['
+ (?:(?:__)?const(?:__)?\s+)?
+ (?:(?:un)?signed\s+)?
+ (?:long\s+)?
+ (?:$typelist)\s+
+ (\w+)
+ (?{ push @local_variables, $1 })
+ ']
+ [my \$$1]gx;
+ $new =~ s['
+ (?:(?:__)?const(?:__)?\s+)?
+ (?:(?:un)?signed\s+)?
+ (?:long\s+)?
+ (?:$typelist)\s+
+ ' \s+ &(\w+) \s* ;
+ (?{ push @local_variables, $1 })
+ ]
+ [my \$$1;]gx;
+ }
+ $new =~ s/&$_\b/\$$_/g for @local_variables;
+ $new =~ s/(["\\])/\\$1/g; #"]);
+ # now that's almost like a macro (we hope)
+ EMIT($proto);
+ }
+ }
+ $Is_converted{$file} = 1;
+ if ($opt_e && exists($bad_file{$file})) {
+ unlink($Dest_dir . '/' . $outfile);
+ $next = '';
+ } else {
+ print OUT "1;\n";
+ queue_includes_from($file) if $opt_a;
+ }
+}
+
+if ($opt_e && (scalar(keys %bad_file) > 0)) {
+ warn "Was unable to convert the following files:\n";
+ warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
+}
+
+exit $Exit;
+
+sub EMIT {
+ my $proto = shift;
+
+ $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 = ();
+ return;
+}
+
+sub expr {
+ if (/\b__asm__\b/) { # freak out
+ $new = '"(assembly code)"';
+ return
+ }
+ 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 {my $hex = $1;
+ $hex =~ s/^0+//;
+ if (length $hex > 8 && !$Config{use64bitint}) {
+ # Croak if nv_preserves_uv_bits < 64 ?
+ $new .= hex(substr($hex, -8)) +
+ 2**32 * hex(substr($hex, 0, -8));
+ # The above will produce "erroneous" code
+ # if the hex constant was e.g. inside UINT64_C
+ # macro, but then again, h2ph is an approximation.
+ } else {
+ $new .= lc("0x$hex");
+ }
+ next;};
+ s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//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 {
+ my $doit = 1;
+ foreach (split /\s+/, $1) { # Make sure all the words are types,
+ unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){
+ $doit = 0;
+ last;
+ }
+ }
+ if( $doit ){
+ 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' || $id eq 'union') {
+ 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*\(/) {
+ s/^\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) {
+ if ($new =~ /defined\s*$/) {
+ $new .= '(&' . $id . ')';
+ } elsif ($new =~ /defined\s*\($/) {
+ $new .= '&' . $id;
+ } else {
+ $new .= '(defined(&' . $id . ') ? &' . $id . ' : undef)';
+ }
+ } elsif (/^\[/) {
+ $new .= " \$$id";
+ } else {
+ $new .= ' &' . $id;
+ }
+ }
+ next;
+ };
+ s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
+ }
+}
+
+
+sub next_line
+{
+ my $file = shift;
+ my ($in, $out);
+ my $pre_sub_tri_graphs = 1;
+
+ READ: while (not eof IN) {
+ $in .= <IN>;
+ chomp $in;
+ next unless length $in;
+
+ while (length $in) {
+ if ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ $in =~ s/\?\?=/#/g; # | ??=| #|
+ $in =~ s/\?\?\!/|/g; # | ??!| ||
+ $in =~ s/\?\?'/^/g; # | ??'| ^|
+ $in =~ s/\?\?\(/[/g; # | ??(| [|
+ $in =~ s/\?\?\)/]/g; # | ??)| ]|
+ $in =~ s/\?\?\-/~/g; # | ??-| ~|
+ $in =~ s/\?\?\//\\/g; # | ??/| \|
+ $in =~ s/\?\?</{/g; # | ??<| {|
+ $in =~ s/\?\?>/}/g; # | ??>| }|
+ }
+ if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
+ # Tru64 disassembler.h evilness: mixed C and Pascal.
+ while (<IN>) {
+ last if /^\#endif/;
+ }
+ $in = "";
+ next READ;
+ }
+ if ($in =~ /^extern inline / && # Inlined assembler.
+ $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
+ while (<IN>) {
+ last if /^}/;
+ }
+ $in = "";
+ next READ;
+ }
+ if ($in =~ s/\\$//) { # \-newline
+ $out .= ' ';
+ next READ;
+ } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
+ $out .= $1;
+ } elsif ($in =~ s/^(\\.)//) { # \...
+ $out .= $1;
+ } elsif ($in =~ /^'/) { # '...
+ if ($in =~ s/^('(\\.|[^'\\])*')//) {
+ $out .= $1;
+ } else {
+ next READ;
+ }
+ } elsif ($in =~ /^"/) { # "...
+ if ($in =~ s/^("(\\.|[^"\\])*")//) {
+ $out .= $1;
+ } else {
+ next READ;
+ }
+ } elsif ($in =~ s/^\/\/.*//) { # //...
+ # fall through
+ } elsif ($in =~ m/^\/\*/) { # /*...
+ # C comment removal adapted from perlfaq6:
+ if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
+ $out .= ' ';
+ } else { # Incomplete /* */
+ next READ;
+ }
+ } elsif ($in =~ s/^(\/)//) { # /...
+ $out .= $1;
+ } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
+ $out .= $1;
+ } elsif ($^O eq 'linux' &&
+ $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
+ $in =~ s!\'T KNOW!!) {
+ $out =~ s!I DON$!I_DO_NOT_KNOW!;
+ } else {
+ if ($opt_e) {
+ warn "Cannot parse $file:\n$in\n";
+ $bad_file{$file} = 1;
+ $in = '';
+ $out = undef;
+ last READ;
+ } else {
+ die "Cannot parse:\n$in\n";
+ }
+ }
+ }
+
+ last READ if $out =~ /\S/;
+ }
+
+ return $out;
+}
+
+
+# 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+([<"])(.*?)[>"]/) {
+ my ($delimiter, $new_file) = ($1, $2);
+ # copy the prefix in the quote syntax (#include "x.h") case
+ if ($delimiter eq q{"} && $file =~ m|^(.*)/|) {
+ $new_file = "$1/$new_file";
+ }
+ push(@ARGV, $new_file) unless $Is_converted{$new_file};
+ }
+ }
+ close HEADER;
+}
+
+
+# Determine include directories; $Config{usrinc} should be enough for (all
+# non-GCC?) C compilers, but gcc uses additional include directories.
+sub inc_dirs
+{
+ my $from_gcc = `LC_ALL=C $Config{cc} -v -E - < /dev/null 2>&1 | awk '/^#include/, /^End of search list/' | grep '^ '`;
+ length($from_gcc) ? (split(' ', $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 = 4;
+ 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";
+ # Prevent non-portable hex constants from warning.
+ #
+ # We still produce an overflow warning if we can't represent
+ # a hex constant as an integer.
+ print PREAMBLE "no warnings qw(portable);\n";
+
+ foreach (sort keys %define) {
+ if ($opt_D) {
+ print PREAMBLE "# $_=$define{$_}\n";
+ }
+ if ($define{$_} =~ /^\((.*)\)$/) {
+ # parenthesized value: d=(v)
+ $define{$_} = $1;
+ }
+ if (/^(\w+)\((\w)\)$/) {
+ my($macro, $arg) = ($1, $2);
+ my $def = $define{$_};
+ $def =~ s/$arg/\$\{$arg\}/g;
+ print PREAMBLE <<DEFINE;
+unless (defined &$macro) { sub $macro(\$) { my (\$$arg) = \@_; \"$def\" } }
+
+DEFINE
+ } elsif
+ ($define{$_} =~ /^([+-]?(\d+)?\.\d+([eE][+-]?\d+)?)[FL]?$/) {
+ # float:
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { $1 } }\n\n";
+ } elsif ($define{$_} =~ /^([+-]?\d+)U?L{0,2}$/i) {
+ # integer:
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { $1 } }\n\n";
+ } elsif ($define{$_} =~ /^([+-]?0x[\da-f]+)U?L{0,2}$/i) {
+ # hex integer
+ # Special cased, since perl warns on hex integers
+ # that can't be represented in a UV.
+ #
+ # This way we get the warning at time of use, so the user
+ # only gets the warning if they happen to use this
+ # platform-specific definition.
+ my $code = $1;
+ $code = "hex('$code')" if length $code > 10;
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { $code } }\n\n";
+ } elsif ($define{$_} =~ /^\w+$/) {
+ my $def = $define{$_};
+ if ($isatype{$def}) {
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { \"$def\" } }\n\n";
+ } else {
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { &$def } }\n\n";
+ }
+ } else {
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { \"",
+ quotemeta($define{$_}), "\" } }\n\n";
+ }
+ }
+ print PREAMBLE "\n1;\n"; # avoid 'did not return a true value' when empty
+ 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:
+ while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
+ $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] [-h] [-e] [-D] [-Q]
+[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 * sys/* arpa/* netinet/*
+
+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{'installsitearch'}>).
+
+=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 -e
+
+If an error is encountered during conversion, output file will be removed and
+a warning emitted instead of terminating the conversion immediately.
+
+=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;
Property changes on: trunk/contrib/perl/utils/h2ph.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/h2xs.PL
===================================================================
--- trunk/contrib/perl/utils/h2xs.PL (rev 0)
+++ trunk/contrib/perl/utils/h2xs.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,2246 @@
+#!/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!';
+
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
+use warnings;
+
+=head1 NAME
+
+h2xs - convert .h C header files to Perl extensions
+
+=head1 SYNOPSIS
+
+B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
+
+B<h2xs> B<-h>|B<-?>|B<--help>
+
+=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.
+
+In spite of its name, I<h2xs> may also be used to create a skeleton pure
+Perl module. See the B<-X> option.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-A>, B<--omit-autoload>
+
+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<-B>, B<--beta-version>
+
+Use an alpha/beta style version number. Causes version number to
+be "0.00_01" unless B<-v> is specified.
+
+=item B<-C>, B<--omit-changes>
+
+Omits creation of the F<Changes> file, and adds a HISTORY section to
+the POD template.
+
+=item B<-F>, B<--cpp-flags>=I<addflags>
+
+Additional flags to specify to C preprocessor when scanning header for
+function declarations. Writes these options in the generated F<Makefile.PL>
+too.
+
+=item B<-M>, B<--func-mask>=I<regular expression>
+
+selects functions/macros to process.
+
+=item B<-O>, B<--overwrite-ok>
+
+Allows a pre-existing extension directory to be overwritten.
+
+=item B<-P>, B<--omit-pod>
+
+Omit the autogenerated stub POD section.
+
+=item B<-X>, B<--omit-XS>
+
+Omit the XS portion. Used to generate a skeleton pure Perl module.
+C<-c> and C<-f> are implicitly enabled.
+
+=item B<-a>, B<--gen-accessors>
+
+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<-b>, B<--compat-version>=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. If unspecified h2xs will default
+to compatibility with the version of perl you are using to run h2xs.
+
+=item B<-c>, B<--omit-constant>
+
+Omit C<constant()> from the .xs file and corresponding specialised
+C<AUTOLOAD> from the .pm file.
+
+=item B<-d>, B<--debugging>
+
+Turn on debugging messages.
+
+=item B<-e>, B<--omit-enums>=[I<regular expression>]
+
+If I<regular expression> is not given, skip all constants that are defined in
+a C enumeration. Otherwise skip only those constants that are defined in an
+enum whose name matches I<regular expression>.
+
+Since I<regular expression> is optional, make sure that this switch is followed
+by at least one other switch if you omit I<regular expression> and have some
+pending arguments such as header-file names. This is ok:
+
+ h2xs -e -n Module::Foo foo.h
+
+This is not ok:
+
+ h2xs -n Module::Foo -e foo.h
+
+In the latter, foo.h is taken as I<regular expression>.
+
+=item B<-f>, B<--force>
+
+Allows an extension to be created for a header even if that header is
+not found in standard include directories.
+
+=item B<-g>, B<--global>
+
+Include code for safely storing static data in the .xs file.
+Extensions that do no make use of static data can ignore this option.
+
+=item B<-h>, B<-?>, B<--help>
+
+Print the usage, help and version for this h2xs and exit.
+
+=item B<-k>, B<--omit-const-func>
+
+For function arguments declared as C<const>, omit the const attribute in the
+generated XS code.
+
+=item B<-m>, B<--gen-tied-var>
+
+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>, B<--name>=I<module_name>
+
+Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
+
+=item B<-o>, B<--opaque-re>=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>, B<--remove-prefix>=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>, B<--const-subs>=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<-t>, B<--default-type>=I<type>
+
+Specify the internal type that the constant() mechanism uses for macros.
+The default is IV (signed integer). Currently all macros found during the
+header scanning process will be assumed to have this type. Future versions
+of C<h2xs> may gain the ability to make educated guesses.
+
+=item B<--use-new-tests>
+
+When B<--compat-version> (B<-b>) is present the generated tests will use
+C<Test::More> rather than C<Test> which is the default for versions before
+5.6.2. C<Test::More> will be added to PREREQ_PM in the generated
+C<Makefile.PL>.
+
+=item B<--use-old-tests>
+
+Will force the generation of test code that uses the older C<Test> module.
+
+=item B<--skip-exporter>
+
+Do not use C<Exporter> and/or export any symbol.
+
+=item B<--skip-ppport>
+
+Do not use C<Devel::PPPort>: no portability to older version.
+
+=item B<--skip-autoloader>
+
+Do not use the module C<AutoLoader>; but keep the constant() function
+and C<sub AUTOLOAD> for constants.
+
+=item B<--skip-strict>
+
+Do not use the pragma C<strict>.
+
+=item B<--skip-warnings>
+
+Do not use the pragma C<warnings>.
+
+=item B<-v>, B<--version>=I<version>
+
+Specify a version number for this extension. This version number is added
+to the templates. The default is 0.01, or 0.00_01 if C<-B> is specified.
+The version specified should be numeric.
+
+=item B<-x>, B<--autogen-xsubs>
+
+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>>.
+
+=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
+
+ # Extension is a pure Perl module with no XS code.
+ h2xs -X My::Module
+
+ # Extension is Lib::Foo which works at least with Perl5.005_03.
+ # Constants are created for all #defines and enums h2xs can find
+ # in foo.h.
+ h2xs -b 5.5.3 -n Lib::Foo foo.h
+
+ # Extension is Lib::Foo which works at least with Perl5.005_03.
+ # Constants are created for all #defines but only for enums
+ # whose names do not start with 'bar_'.
+ h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h
+
+ # 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 accessible 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
+
+# ' # Grr
+use strict;
+
+
+my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/;
+my $TEMPLATE_VERSION = '0.01';
+my @ARGS = @ARGV;
+my $compat_version = $];
+
+use Getopt::Long;
+use Config;
+use Text::Wrap;
+$Text::Wrap::huge = 'overflow';
+$Text::Wrap::columns = 80;
+use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload);
+use File::Compare;
+use File::Path;
+
+sub usage {
+ warn "@_\n" if @_;
+ die <<EOFUSAGE;
+h2xs [OPTIONS ... ] [headerfile [extra_libraries]]
+version: $H2XS_VERSION
+OPTIONS:
+ -A, --omit-autoload Omit all autoloading facilities (implies -c).
+ -B, --beta-version Use beta \$VERSION of 0.00_01 (ignored if -v).
+ -C, --omit-changes Omit creating the Changes file, add HISTORY heading
+ to stub POD.
+ -F, --cpp-flags Additional flags for C preprocessor/compile.
+ -M, --func-mask Mask to select C functions/macros
+ (default is select all).
+ -O, --overwrite-ok Allow overwriting of a pre-existing extension directory.
+ -P, --omit-pod Omit the stub POD section.
+ -X, --omit-XS Omit the XS portion (implies both -c and -f).
+ -a, --gen-accessors Generate get/set accessors for struct and union members
+ (used with -x).
+ -b, --compat-version Specify a perl version to be backwards compatible with.
+ -c, --omit-constant Omit the constant() function and specialised AUTOLOAD
+ from the XS file.
+ -d, --debugging Turn on debugging messages.
+ -e, --omit-enums Omit constants from enums in the constant() function.
+ If a pattern is given, only the matching enums are
+ ignored.
+ -f, --force Force creation of the extension even if the C header
+ does not exist.
+ -g, --global Include code for safely storing static data in the .xs file.
+ -h, -?, --help Display this help message.
+ -k, --omit-const-func Omit 'const' attribute on function arguments
+ (used with -x).
+ -m, --gen-tied-var Generate tied variables for access to declared
+ variables.
+ -n, --name Specify a name to use for the extension (recommended).
+ -o, --opaque-re Regular expression for \"opaque\" types.
+ -p, --remove-prefix Specify a prefix which should be removed from the
+ Perl function names.
+ -s, --const-subs Create subroutines for specified macros.
+ -t, --default-type Default type for autoloaded constants (default is IV).
+ --use-new-tests Use Test::More in backward compatible modules.
+ --use-old-tests Use the module Test rather than Test::More.
+ --skip-exporter Do not export symbols.
+ --skip-ppport Do not use portability layer.
+ --skip-autoloader Do not use the module C<AutoLoader>.
+ --skip-strict Do not use the pragma C<strict>.
+ --skip-warnings Do not use the pragma C<warnings>.
+ -v, --version Specify a version number for this extension.
+ -x, --autogen-xsubs Autogenerate XSUBs using C::Scan.
+ --use-xsloader Use XSLoader in backward compatible modules (ignored
+ when used with -X).
+
+extra_libraries
+ are any libraries that might be needed for loading the
+ extension, e.g. -lm would try to link in the math library.
+EOFUSAGE
+}
+
+my ($opt_A,
+ $opt_B,
+ $opt_C,
+ $opt_F,
+ $opt_M,
+ $opt_O,
+ $opt_P,
+ $opt_X,
+ $opt_a,
+ $opt_c,
+ $opt_d,
+ $opt_e,
+ $opt_f,
+ $opt_g,
+ $opt_h,
+ $opt_k,
+ $opt_m,
+ $opt_n,
+ $opt_o,
+ $opt_p,
+ $opt_s,
+ $opt_v,
+ $opt_x,
+ $opt_b,
+ $opt_t,
+ $new_test,
+ $old_test,
+ $skip_exporter,
+ $skip_ppport,
+ $skip_autoloader,
+ $skip_strict,
+ $skip_warnings,
+ $use_xsloader
+ );
+
+Getopt::Long::Configure('bundling');
+Getopt::Long::Configure('pass_through');
+
+my %options = (
+ 'omit-autoload|A' => \$opt_A,
+ 'beta-version|B' => \$opt_B,
+ 'omit-changes|C' => \$opt_C,
+ 'cpp-flags|F=s' => \$opt_F,
+ 'func-mask|M=s' => \$opt_M,
+ 'overwrite_ok|O' => \$opt_O,
+ 'omit-pod|P' => \$opt_P,
+ 'omit-XS|X' => \$opt_X,
+ 'gen-accessors|a' => \$opt_a,
+ 'compat-version|b=s' => \$opt_b,
+ 'omit-constant|c' => \$opt_c,
+ 'debugging|d' => \$opt_d,
+ 'omit-enums|e:s' => \$opt_e,
+ 'force|f' => \$opt_f,
+ 'global|g' => \$opt_g,
+ 'help|h|?' => \$opt_h,
+ 'omit-const-func|k' => \$opt_k,
+ 'gen-tied-var|m' => \$opt_m,
+ 'name|n=s' => \$opt_n,
+ 'opaque-re|o=s' => \$opt_o,
+ 'remove-prefix|p=s' => \$opt_p,
+ 'const-subs|s=s' => \$opt_s,
+ 'default-type|t=s' => \$opt_t,
+ 'version|v=s' => \$opt_v,
+ 'autogen-xsubs|x' => \$opt_x,
+ 'use-new-tests' => \$new_test,
+ 'use-old-tests' => \$old_test,
+ 'skip-exporter' => \$skip_exporter,
+ 'skip-ppport' => \$skip_ppport,
+ 'skip-autoloader' => \$skip_autoloader,
+ 'skip-warnings' => \$skip_warnings,
+ 'skip-strict' => \$skip_strict,
+ 'use-xsloader' => \$use_xsloader,
+ );
+
+GetOptions(%options) || usage;
+
+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 =~ /^v?(\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) = ($1,$2,$3);
+ if ($maj < 5 || ($maj == 5 && $min < 6)) {
+ $compat_version =
+ $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :
+ sprintf("%d.%03d", $maj,$min);
+ } else {
+ $compat_version = sprintf("%d.%03d%03d",$maj,$min,$sub);
+ }
+} else {
+ my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;
+ $sub ||= 0;
+ warn sprintf <<'EOF', $maj,$min,$sub;
+Defaulting to backwards compatibility with perl %d.%d.%d
+If you intend this module to be compatible with earlier perl versions, please
+specify a minimum perl version with the -b option.
+
+EOF
+}
+
+if( $opt_B ){
+ $TEMPLATE_VERSION = '0.00_01';
+}
+
+if( $opt_v ){
+ $TEMPLATE_VERSION = $opt_v;
+
+ # check if it is numeric
+ my $temp_version = $TEMPLATE_VERSION;
+ my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;
+ my $notnum;
+ {
+ local $SIG{__WARN__} = sub { $notnum = 1 };
+ use warnings 'numeric';
+ $temp_version = 0+$temp_version;
+ }
+
+ if ($notnum) {
+ my $module = $opt_n || 'Your::Module';
+ warn <<"EOF";
+You have specified a non-numeric version. Unless you supply an
+appropriate VERSION class method, users may not be able to specify a
+minimum required version with C<use $module versionnum>.
+
+EOF
+ }
+ else {
+ $opt_B = $beta_version;
+ }
+}
+
+# -A implies -c.
+$skip_autoloader = $opt_c = 1 if $opt_A;
+
+# -X implies -c and -f
+$opt_c = $opt_f = 1 if $opt_X;
+
+$opt_t ||= 'IV';
+
+my %const_xsub;
+%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 ";
+ next;
+ }
+ last if $extralibs;
+ 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 if $opt_o;
+Option -o does not make sense without -x.
+EOD
+ warn <<EOD if $opt_F and $opt_X ;
+Option -F does not make sense with -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 File::Spec;
+ my @paths;
+ my $pre_sub_tri_graphs = 1;
+ 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;
+ $fullpath{$path_h} = $fullpath;
+ } 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 ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ s/\?\?=/#/g; # | ??=| #|
+ s/\?\?\!/|/g; # | ??!| ||
+ s/\?\?'/^/g; # | ??'| ^|
+ s/\?\?\(/[/g; # | ??(| [|
+ s/\?\?\)/]/g; # | ??)| ]|
+ s/\?\?\-/~/g; # | ??-| ~|
+ s/\?\?\//\\/g; # | ??/| \|
+ s/\?\?</{/g; # | ??<| {|
+ s/\?\?>/}/g; # | ??>| }|
+ }
+ if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
+ my $def = $1;
+ my $rest = $2;
+ $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
+ $rest =~ s/^\s+//;
+ $rest =~ s/\s+$//;
+ if ($rest eq '') {
+ print("Skip empty $def\n") if $opt_d;
+ next defines;
+ }
+ # 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{$_}++;
+ }
+ }
+ }
+ if (defined $opt_e and !$opt_e) {
+ close(CH);
+ }
+ else {
+ # Work from miniperl too - on "normal" systems
+ my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' || 0;
+ seek CH, 0, $SEEK_SET;
+ my $src = do { local $/; <CH> };
+ close CH;
+ no warnings 'uninitialized';
+
+ # Remove C and C++ comments
+ $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
+ $src =~ s#//.*$##gm;
+
+ while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) {
+ my ($enum_name, $enum_body) = ($1, $2);
+ # skip enums matching $opt_e
+ next if $opt_e && $enum_name =~ /$opt_e/;
+ my $val = 0;
+ for my $item (split /,/, $enum_body) {
+ next if $item =~ /\A\s*\Z/;
+ my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/;
+ $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val;
+ $seen_define{$key} = $val;
+ $const_names{$key} = { name => $key, macro => 1 };
+ }
+ } # while (...)
+ } # if (!defined $opt_e or $opt_e)
+ }
+ }
+}
+
+# Save current directory so that C::Scan can use it
+my $cwd = File::Spec->rel2abs( File::Spec->curdir );
+
+# As Ilya suggested, use a name that contains - and then it can't clash with
+# the names of any packages. A directory 'fallback' will clash with any
+# new pragmata down the fallback:: tree, but that seems unlikely.
+my $constscfname = 'const-c.inc';
+my $constsxsfname = 'const-xs.inc';
+my $fallbackdirname = 'fallback';
+
+my $ext = chdir 'ext' ? 'ext/' : '';
+
+my @modparts = split(/::/,$module);
+my $modpname = join('-', @modparts);
+my $modfname = pop @modparts;
+my $modpmdir = join '/', 'lib', @modparts;
+my $modpmname = join '/', $modpmdir, $modfname.'.pm';
+
+if ($opt_O) {
+ warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
+}
+else {
+ die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
+}
+-d "$modpname" || mkpath([$modpname], 0, 0775);
+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
+ unless ($skip_ppport) {
+ require Devel::PPPort;
+ warn "Writing $ext$modpname/ppport.h\n";
+ Devel::PPPort::WriteFile('ppport.h')
+ || die "Can't create $ext$modpname/ppport.h: $!\n";
+ }
+ open(XS, ">", "$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
+ if ($opt_x) {
+ 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";
+ my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
+ $c = C::Scan->new('filename' => $filename, 'filename_filter' => $filter,
+ 'add_cppflags' => $addflags, 'c_styles' => \@styles);
+ $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
+
+ $c->get('keywords')->{'__restrict'} = 1;
+
+ 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 )(?<!enum )(?:@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
+ if defined $opt_p;
+ # 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_specs, @const_names);
+
+for (sort(keys(%const_names))) {
+ my $v = $const_names{$_};
+
+ push(@const_specs, ref($v) ? $v : $_);
+ push(@const_names, $_);
+}
+
+-d $modpmdir || mkpath([$modpmdir], 0, 0775);
+open(PM, ">", "$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n";
+
+$" = "\n\t";
+warn "Writing $ext$modpname/$modpmname\n";
+
+print PM <<"END";
+package $module;
+
+use $compat_version;
+END
+
+print PM <<"END" unless $skip_strict;
+use strict;
+END
+
+print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
+
+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' unless $skip_exporter;
+
+require Exporter;
+END
+
+my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader);
+print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled
+require DynaLoader;
+END
+
+
+# Are we using AutoLoader or not?
+unless ($skip_autoloader) { # 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 ) {
+ my $vars = '$VERSION @ISA';
+ $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
+ $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
+ $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
+ print PM "use vars qw($vars);";
+}
+
+# Determine @ISA.
+my @modISA;
+push @modISA, 'Exporter' unless $skip_exporter;
+push @modISA, 'DynaLoader' if $use_Dyna; # no XS
+my $myISA = "our \@ISA = qw(@modISA);";
+$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='';
+$tmp .= <<"END" unless $skip_exporter;
+# 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
+);
+
+END
+
+$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
+if ($opt_B) {
+ $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
+ $tmp .= "\$VERSION = eval \$VERSION; # see L<perlmodstyle>\n";
+}
+$tmp .= "\n";
+
+$tmp =~ s/^our //mg if $compat_version < 5.006;
+print PM $tmp;
+
+if (@vdecls) {
+ printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
+}
+
+
+print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
+
+if( ! $opt_X ){ # print bootstrap, unless XS is disabled
+ if ($use_Dyna) {
+ $tmp = <<"END";
+bootstrap $module \$VERSION;
+END
+ } else {
+ $tmp = <<"END";
+require XSLoader;
+XSLoader::load('$module', \$VERSION);
+END
+ }
+ $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
+ print PM $tmp;
+}
+
+# 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 ($email,$author,$licence);
+
+eval {
+ my $username;
+ ($username,$author) = (getpwuid($>))[0,6];
+ if (defined $username && defined $author) {
+ $author =~ s/,.*$//; # in case of sub fields
+ my $domain = $Config{'mydomain'};
+ $domain =~ s/^\.//;
+ $email = "$username\@$domain";
+ }
+ };
+
+$author =~ s/'/\\'/g if defined $author;
+$author ||= "A. U. Thor";
+$email ||= 'a.u.thor at a.galaxy.far.far.away';
+
+$licence = sprintf << "DEFAULT", $^V;
+Copyright (C) ${\(1900 + (localtime) [5])} by $author
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version %vd or,
+at your option, any later version of Perl 5 you may have available.
+DEFAULT
+
+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 = $skip_exporter ? '' : <<EOD;
+#
+#=head2 EXPORT
+#
+#None by default.
+#
+EOD
+
+if (@const_names and not $opt_P) {
+ $exp_doc .= <<EOD unless $skip_exporter;
+#=head2 Exportable constants
+#
+# @{[join "\n ", @const_names]}
+#
+EOD
+}
+
+if (defined $fdecls and @$fdecls and not $opt_P) {
+ $exp_doc .= <<EOD unless $skip_exporter;
+#=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 unless $skip_exporter;
+# @{[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;
+}
+
+# Prefix the default licence with hash symbols.
+# Is this just cargo cult - it seems that the first thing that happens to this
+# block is that all the hashes are then s///g out.
+my $licence_hash = $licence;
+$licence_hash =~ s/^/#/gm;
+
+my $pod;
+$pod = <<"END" unless $opt_P;
+## Below is stub documentation for your module. You'd 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 SEE ALSO
+#
+#Mention other useful documentation such as the documentation of
+#related modules or operating system documentation (such as man pages
+#in UNIX), or any relevant external documentation such as RFCs or
+#standards.
+#
+#If you have a mailing list set up for your module, mention it here.
+#
+#If you have a web site set up for your module, mention it here.
+#
+#=head1 AUTHOR
+#
+#$author, E<lt>${email}E<gt>
+#
+#=head1 COPYRIGHT AND LICENSE
+#
+$licence_hash
+#
+#=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";
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+END
+
+print XS <<"END" unless $skip_ppport;
+#include "ppport.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";
+}
+
+print XS <<"END" if $opt_g;
+
+/* Global Data */
+
+#define MY_CXT_KEY "${module}::_guts" XS_VERSION
+
+typedef struct {
+ /* Put Global Data in here */
+ int dummy; /* you can access this elsewhere as MY_CXT.dummy */
+} my_cxt_t;
+
+START_MY_CXT
+
+END
+
+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);
+}
+
+print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
+
+if( ! $opt_c ) {
+ # We write the "sample" files used when this module is built by perl without
+ # ExtUtils::Constant.
+ # h2xs will later check that these are the same as those generated by the
+ # code embedded into Makefile.PL
+ unless (-d $fallbackdirname) {
+ mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
+ }
+ warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
+ warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
+ my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
+ my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
+ WriteConstants ( C_FILE => $cfallback,
+ XS_FILE => $xsfallback,
+ DEFAULT_TYPE => $opt_t,
+ NAME => $module,
+ NAMES => \@const_specs,
+ );
+ print XS "#include \"$constscfname\"\n";
+}
+
+
+my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
+
+# Now switch from C to XS by issuing the first MODULE declaration:
+print XS <<"END";
+
+MODULE = $module PACKAGE = $module $prefix
+
+END
+
+# If a constant() function was #included then output a corresponding
+# XS declaration:
+print XS "INCLUDE: $constsxsfname\n" unless $opt_c;
+
+print XS <<"END" if $opt_g;
+
+BOOT:
+{
+ MY_CXT_INIT;
+ /* If any of the fields in the my_cxt_t struct need
+ to be initialised, do it here.
+ */
+}
+
+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
+}
+
+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 exercises 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_NV';
+
+ 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 heuristic 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);
+ }
+ # XXX good do better if our UV happens to be long long
+ return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
+ $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";
+
+my $prereq_pm = '';
+
+if ( $compat_version < 5.006002 and $new_test )
+{
+ $prereq_pm .= q%'Test::More' => 0, %;
+}
+elsif ( $compat_version < 5.006002 )
+{
+ $prereq_pm .= q%'Test' => 0, %;
+}
+
+if (!$opt_X and $use_xsloader)
+{
+ $prereq_pm .= q%'XSLoader' => 0, %;
+}
+
+print PL <<"END";
+use $compat_version;
+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 => '$modpmname', # finds \$VERSION, requires EU::MM from perl >= 5.5
+ PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1
+ ABSTRACT_FROM => '$modpmname', # retrieve abstract from module
+ AUTHOR => '$author <$email>',
+ #LICENSE => 'perl',
+ #Value must be from legacy list of licenses here
+ #http://search.cpan.org/perldoc?Module%3A%3ABuild%3A%3AAPI
+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
+} # ' # Grr
+print PL ");\n";
+if (!$opt_c) {
+ my $generate_code =
+ WriteMakefileSnippet ( C_FILE => $constscfname,
+ XS_FILE => $constsxsfname,
+ DEFAULT_TYPE => $opt_t,
+ NAME => $module,
+ NAMES => \@const_specs,
+ );
+ print PL <<"END";
+if (eval {require ExtUtils::Constant; 1}) {
+ # If you edit these definitions to change the constants used by this module,
+ # you will need to use the generated $constscfname and $constsxsfname
+ # files to replace their "fallback" counterparts before distributing your
+ # changes.
+$generate_code
+}
+else {
+ use File::Copy;
+ use File::Spec;
+ foreach my \$file ('$constscfname', '$constsxsfname') {
+ my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
+ copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
+ }
+}
+END
+
+ eval $generate_code;
+ if ($@) {
+ warn <<"EOM";
+Attempting to test constant code in $ext$modpname/Makefile.PL:
+$generate_code
+__END__
+gave unexpected error $@
+Please report the circumstances of this bug in h2xs version $H2XS_VERSION
+using the perlbug script.
+EOM
+ } else {
+ my $fail;
+
+ foreach my $file ($constscfname, $constsxsfname) {
+ my $fallback = File::Spec->catfile($fallbackdirname, $file);
+ if (compare($file, $fallback)) {
+ warn << "EOM";
+Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
+EOM
+ $fail++;
+ }
+ }
+ if ($fail) {
+ warn fill ('','', <<"EOM") . "\n";
+It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
+the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
+correctly.
+
+Please report the circumstances of this bug in h2xs version $H2XS_VERSION
+using the perlbug script.
+EOM
+ } else {
+ unlink $constscfname, $constsxsfname;
+ }
+ }
+}
+close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
+
+# Create a simple README since this is a CPAN requirement
+# and it doesn't 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);
+
+my $rm_prereq;
+
+if ( $compat_version < 5.006002 and $new_test )
+{
+ $rm_prereq = 'Test::More';
+}
+elsif ( $compat_version < 5.006002 )
+{
+ $rm_prereq = 'Test';
+}
+else
+{
+ $rm_prereq = 'blah blah blah';
+}
+
+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:
+
+ $rm_prereq
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+$licence
+
+_RMEND_
+close(RM) || die "Can't close $ext$modpname/README: $!\n";
+
+my $testdir = "t";
+my $testfile = "$testdir/$modpname.t";
+unless (-d "$testdir") {
+ mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
+}
+warn "Writing $ext$modpname/$testfile\n";
+my $tests = @const_names ? 2 : 1;
+
+open EX, ">", "$testfile" or die "Can't create $ext$modpname/$testfile: $!\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 $modpname.t'
+
+#########################
+
+# change 'tests => $tests' to 'tests => last_test_to_print';
+
+use strict;
+use warnings;
+
+_END_
+
+my $test_mod = 'Test::More';
+
+if ( $old_test or ($compat_version < 5.006002 and not $new_test ))
+{
+ my $test_mod = 'Test';
+
+ print EX <<_END_;
+use Test;
+BEGIN { plan tests => $tests };
+use $module;
+ok(1); # If we made it this far, we're ok.
+
+_END_
+
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
+
+my $fail;
+foreach my $constname (qw(
+_END_
+
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+
+ print EX <<_END_;
+ next if (eval "my \\\$a = \$constname; 1");
+ if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
+ print "# pass: \$\@";
+ } else {
+ print "# fail: \$\@";
+ \$fail = 1;
+ }
+}
+if (\$fail) {
+ print "not ok 2\\n";
+} else {
+ print "ok 2\\n";
+}
+
+_END_
+ }
+}
+else
+{
+ print EX <<_END_;
+use Test::More tests => $tests;
+BEGIN { use_ok('$module') };
+
+_END_
+
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
+
+my $fail = 0;
+foreach my $constname (qw(
+_END_
+
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+
+ print EX <<_END_;
+ next if (eval "my \\\$a = \$constname; 1");
+ if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
+ print "# pass: \$\@";
+ } else {
+ print "# fail: \$\@";
+ \$fail = 1;
+ }
+
+}
+
+ok( \$fail == 0 , 'Constants' );
+_END_
+ }
+}
+
+print EX <<_END_;
+#########################
+
+# Insert your test code below, the $test_mod module is use()ed here so read
+# its man page ( perldoc $test_mod ) for help writing this test script.
+
+_END_
+
+close(EX) || die "Can't close $ext$modpname/$testfile: $!\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 at 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 = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>);
+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", at 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;
Property changes on: trunk/contrib/perl/utils/h2xs.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/instmodsh.PL
===================================================================
--- trunk/contrib/perl/utils/instmodsh.PL (rev 0)
+++ trunk/contrib/perl/utils/instmodsh.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $instmodsh
+ = File::Spec->catfile(File::Spec->catdir(File::Spec->updir,
+ qw(cpan ExtUtils-MakeMaker bin)),
+ 'instmodsh');
+
+if (open(INSTMODSH, '<', $instmodsh)) {
+ print OUT <INSTMODSH>;
+ close INSTMODSH;
+} else {
+ die "$0: cannot find '$instmodsh'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/instmodsh.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/json_pp.PL
===================================================================
--- trunk/contrib/perl/utils/json_pp.PL (rev 0)
+++ trunk/contrib/perl/utils/json_pp.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $script = File::Spec->catfile(
+ File::Spec->catdir(
+ File::Spec->updir, qw[cpan JSON-PP bin]
+ ), "json_pp");
+
+if (open(IN, '<', $script)) {
+ print OUT <IN>;
+ close IN;
+} else {
+ die "$0: cannot find '$script'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/json_pp.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/libnetcfg.PL
===================================================================
--- trunk/contrib/perl/utils/libnetcfg.PL (rev 0)
+++ trunk/contrib/perl/utils/libnetcfg.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,761 @@
+#!/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
+
+libnetcfg - configure libnet
+
+=head1 DESCRIPTION
+
+The libnetcfg utility can be used to configure the libnet.
+Starting from perl 5.8 libnet is part of the standard Perl
+distribution, but the libnetcfg can be used for any libnet
+installation.
+
+=head1 USAGE
+
+Without arguments libnetcfg displays the current configuration.
+
+ $ libnetcfg
+ # old config ./libnet.cfg
+ daytime_hosts ntp1.none.such
+ ftp_int_passive 0
+ ftp_testhost ftp.funet.fi
+ inet_domain none.such
+ nntp_hosts nntp.none.such
+ ph_hosts
+ pop3_hosts pop.none.such
+ smtp_hosts smtp.none.such
+ snpp_hosts
+ test_exist 1
+ test_hosts 1
+ time_hosts ntp.none.such
+ # libnetcfg -h for help
+ $
+
+It tells where the old configuration file was found (if found).
+
+The C<-h> option will show a usage message.
+
+To change the configuration you will need to use either the C<-c> or
+the C<-d> options.
+
+The default name of the old configuration file is by default
+"libnet.cfg", unless otherwise specified using the -i option,
+C<-i oldfile>, and it is searched first from the current directory,
+and then from your module path.
+
+The default name of the new configuration file is "libnet.cfg", and by
+default it is written to the current directory, unless otherwise
+specified using the -o option, C<-o newfile>.
+
+=head1 SEE ALSO
+
+L<Net::Config>, L<libnetFAQ>
+
+=head1 AUTHORS
+
+Graham Barr, the original Configure script of libnet.
+
+Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
+
+=cut
+
+# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
+
+BEGIN { pop @INC if $INC[-1] eq '.' }
+use strict;
+use IO::File;
+use Getopt::Std;
+use ExtUtils::MakeMaker qw(prompt);
+use File::Spec;
+
+use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
+
+##
+##
+##
+
+my %cfg = ();
+my @cfg = ();
+
+my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
+
+##
+##
+##
+
+sub valid_host
+{
+ my $h = shift;
+
+ defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
+}
+
+##
+##
+##
+
+sub test_hostnames (\@)
+{
+ my $hlist = shift;
+ my @h = ();
+ my $host;
+ my $err = 0;
+
+ foreach $host (@$hlist)
+ {
+ if(valid_host($host))
+ {
+ push(@h, $host);
+ next;
+ }
+ warn "Bad hostname: '$host'\n";
+ $err++;
+ }
+ @$hlist = @h;
+ $err ? join(" ", at h) : undef;
+}
+
+##
+##
+##
+
+sub Prompt
+{
+ my($prompt,$def) = @_;
+
+ $def = "" unless defined $def;
+
+ chomp($prompt);
+
+ if($opt_d)
+ {
+ print $prompt,," [",$def,"]\n";
+ return $def;
+ }
+ prompt($prompt,$def);
+}
+
+##
+##
+##
+
+sub get_host_list
+{
+ my($prompt,$def) = @_;
+
+ $def = join(" ",@$def) if ref($def);
+
+ my @hosts;
+
+ do
+ {
+ my $ans = Prompt($prompt,$def);
+
+ $ans =~ s/(\A\s+|\s+\Z)//g;
+
+ @hosts = split(/\s+/, $ans);
+ }
+ while(@hosts && defined($def = test_hostnames(@hosts)));
+
+ \@hosts;
+}
+
+##
+##
+##
+
+sub get_hostname
+{
+ my($prompt,$def) = @_;
+
+ my $host;
+
+ while(1)
+ {
+ my $ans = Prompt($prompt,$def);
+ $host = ($ans =~ /(\S*)/)[0];
+ last
+ if(!length($host) || valid_host($host));
+
+ $def =""
+ if $def eq $host;
+
+ print <<"EDQ";
+
+*** ERROR:
+ Hostname '$host' does not seem to exist, please enter again
+ or a single space to clear any default
+
+EDQ
+ }
+
+ length $host
+ ? $host
+ : undef;
+}
+
+##
+##
+##
+
+sub get_bool ($$)
+{
+ my($prompt,$def) = @_;
+
+ chomp($prompt);
+
+ my $val = Prompt($prompt,$def ? "yes" : "no");
+
+ $val =~ /^y/i ? 1 : 0;
+}
+
+##
+##
+##
+
+sub get_netmask ($$)
+{
+ my($prompt,$def) = @_;
+
+ chomp($prompt);
+
+ my %list;
+ @list{@$def} = ();
+
+MASK:
+ while(1) {
+ my $bad = 0;
+ my $ans = Prompt($prompt) or last;
+
+ if($ans eq '*') {
+ %list = ();
+ next;
+ }
+
+ if($ans eq '=') {
+ print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
+ next;
+ }
+
+ unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
+ warn "Bad netmask '$ans'\n";
+ next;
+ }
+
+ my($remove,$bits, at ip) = ($1,$3,split(/\./, $2),0,0,0);
+ if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
+ warn "Bad netmask '$ans'\n";
+ next MASK;
+ }
+ foreach my $byte (@ip) {
+ if ( $byte > 255 ) {
+ warn "Bad netmask '$ans'\n";
+ next MASK;
+ }
+ }
+
+ my $mask = sprintf("%d.%d.%d.%d/%d", at ip[0..3],$bits);
+
+ if ($remove) {
+ delete $list{$mask};
+ }
+ else {
+ $list{$mask} = 1;
+ }
+
+ }
+
+ [ keys %list ];
+}
+
+##
+##
+##
+
+sub default_hostname
+{
+ my $host;
+ my @host;
+
+ foreach $host (@_)
+ {
+ if(defined($host) && valid_host($host))
+ {
+ return $host
+ unless wantarray;
+ push(@host,$host);
+ }
+ }
+
+ return wantarray ? @host : undef;
+}
+
+##
+##
+##
+
+getopts('dcho:i:');
+
+$libnet_cfg_in = "libnet.cfg"
+ unless(defined($libnet_cfg_in = $opt_i));
+
+$libnet_cfg_out = "libnet.cfg"
+ unless(defined($libnet_cfg_out = $opt_o));
+
+my %oldcfg = ();
+
+$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
+if( -f $libnet_cfg_in )
+ {
+ %oldcfg = ( %{ local @INC = '.'; do $libnet_cfg_in } );
+ }
+elsif (eval { require Net::Config })
+ {
+ $have_old = 1;
+ %oldcfg = %Net::Config::NetConfig;
+ }
+
+map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
+
+#---------------------------------------------------------------------------
+
+if ($opt_h) {
+ print <<EOU;
+$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
+Without options, the old configuration is shown.
+
+ -c change the configuration
+ -d use defaults from the old config (implies -c, non-interactive)
+ -i use a specific file as the old config file
+ -o use a specific file as the new config file
+ -h show this help
+
+The default name of the old configuration file is by default
+"libnet.cfg", unless otherwise specified using the -i option,
+C<-i oldfile>, and it is searched first from the current directory,
+and then from your module path.
+
+The default name of the new configuration file is "libnet.cfg", and by
+default it is written to the current directory, unless otherwise
+specified using the -o option.
+
+EOU
+ exit(0);
+}
+
+#---------------------------------------------------------------------------
+
+{
+ my $oldcfgfile;
+ my @inc;
+ push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
+ push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB};
+ push @inc, @INC;
+ for (@inc) {
+ my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
+ if (-f $trycfgfile && -r $trycfgfile) {
+ $oldcfgfile = $trycfgfile;
+ last;
+ }
+ }
+ print "# old config $oldcfgfile\n" if defined $oldcfgfile;
+ for (sort keys %oldcfg) {
+ printf "%-20s %s\n", $_,
+ ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
+ }
+ unless ($opt_c || $opt_d) {
+ print "# $0 -h for help\n";
+ exit(0);
+ }
+}
+
+#---------------------------------------------------------------------------
+
+$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
+$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
+
+#---------------------------------------------------------------------------
+
+if($have_old && !$opt_d)
+ {
+ $msg = <<EDQ;
+
+Ah, I see you already have installed libnet before.
+
+Do you want to modify/update your configuration (y|n) ?
+EDQ
+
+ $opt_d = 1
+ unless get_bool($msg,0);
+ }
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+This script will prompt you to enter hostnames that can be used as
+defaults for some of the modules in the libnet distribution.
+
+To ensure that you do not enter an invalid hostname, I can perform a
+lookup on each hostname you enter. If your internet connection is via
+a dialup line then you may not want me to perform these lookups, as
+it will require you to be on-line.
+
+Do you want me to perform hostname lookups (y|n) ?
+EDQ
+
+$cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
+
+print <<EDQ unless $cfg{'test_exist'};
+
+*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+
+OK I will not check if the hostnames you give are valid
+so be very cafeful
+
+*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+EDQ
+
+
+#---------------------------------------------------------------------------
+
+print <<EDQ;
+
+The following questions all require a list of host names, separated
+with spaces. If you do not have a host available for any of the
+services, then enter a single space, followed by <CR>. To accept the
+default, hit <CR>
+
+EDQ
+
+$msg = 'Enter a list of available NNTP hosts :';
+
+$def = $oldcfg{'nntp_hosts'} ||
+ [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
+
+$cfg{'nntp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available SMTP hosts :';
+
+$def = $oldcfg{'smtp_hosts'} ||
+ [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
+
+$cfg{'smtp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available POP3 hosts :';
+
+$def = $oldcfg{'pop3_hosts'} || [];
+
+$cfg{'pop3_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available SNPP hosts :';
+
+$def = $oldcfg{'snpp_hosts'} || [];
+
+$cfg{'snpp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available PH Hosts :' ;
+
+$def = $oldcfg{'ph_hosts'} ||
+ [ default_hostname('dirserv') ];
+
+$cfg{'ph_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available TIME Hosts :' ;
+
+$def = $oldcfg{'time_hosts'} || [];
+
+$cfg{'time_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available DAYTIME Hosts :' ;
+
+$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
+
+$cfg{'daytime_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+Do you have a firewall/ftp proxy between your machine and the internet
+
+If you use a SOCKS firewall answer no
+
+(y|n) ?
+EDQ
+
+if(get_bool($msg,0)) {
+
+ $msg = <<'EDQ';
+What series of FTP commands do you need to send to your
+firewall to connect to an external host.
+
+user/pass => external user & password
+fwuser/fwpass => firewall user & password
+
+0) None
+1) -----------------------
+ USER user at remote.host
+ PASS pass
+2) -----------------------
+ USER fwuser
+ PASS fwpass
+ USER user at remote.host
+ PASS pass
+3) -----------------------
+ USER fwuser
+ PASS fwpass
+ SITE remote.site
+ USER user
+ PASS pass
+4) -----------------------
+ USER fwuser
+ PASS fwpass
+ OPEN remote.site
+ USER user
+ PASS pass
+5) -----------------------
+ USER user at fwuser@remote.site
+ PASS pass at fwpass
+6) -----------------------
+ USER fwuser at remote.site
+ PASS fwpass
+ USER user
+ PASS pass
+7) -----------------------
+ USER user at remote.host
+ PASS pass
+ AUTH fwuser
+ RESP fwpass
+
+Choice:
+EDQ
+ $def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1;
+ $ans = Prompt($msg,$def);
+ $cfg{'ftp_firewall_type'} = 0+$ans;
+ $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
+
+ $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
+}
+else {
+ delete $cfg{'ftp_firewall'};
+}
+
+
+#---------------------------------------------------------------------------
+
+if (defined $cfg{'ftp_firewall'})
+ {
+ print <<EDQ;
+
+By default Net::FTP assumes that it only needs to use a firewall if it
+cannot resolve the name of the host given. This only works if your DNS
+system is setup to only resolve internal hostnames. If this is not the
+case and your DNS will resolve external hostnames, then another method
+is needed. Net::Config can do this if you provide the netmasks that
+describe your internal network. Each netmask should be entered in the
+form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
+
+EDQ
+$def = [];
+if(ref($oldcfg{'local_netmask'}))
+ {
+ $def = $oldcfg{'local_netmask'};
+ print "Your current netmasks are :\n\n\t",
+ join("\n\t",@{$def}),"\n\n";
+ }
+
+print "
+Enter one netmask at each prompt, prefix with a - to remove a netmask
+from the list, enter a '*' to clear the whole list, an '=' to show the
+current list and an empty line to continue with Configure.
+
+";
+
+ my $mask = get_netmask("netmask :",$def);
+ $cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
+ }
+
+#---------------------------------------------------------------------------
+
+###$msg =<<EDQ;
+###
+###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
+###then enter a list of hostames
+###
+###Enter a list of available SOCKS hosts :
+###EDQ
+###
+###$def = $cfg{'socks_hosts'} ||
+### [ default_hostname($ENV{SOCKS5_SERVER},
+### $ENV{SOCKS_SERVER},
+### $ENV{SOCKS4_SERVER}) ];
+###
+###$cfg{'socks_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+print <<EDQ;
+
+Normally when FTP needs a data connection the client tells the server
+a port to connect to, and the server initiates a connection to the client.
+
+Some setups, in particular firewall setups, can/do not work using this
+protocol. In these situations the client must make the connection to the
+server, this is called a passive transfer.
+EDQ
+
+if (defined $cfg{'ftp_firewall'}) {
+ $msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
+
+ $def = $oldcfg{'ftp_ext_passive'} || 0;
+
+ $cfg{'ftp_ext_passive'} = get_bool($msg,$def);
+
+ $msg = "\nShould all other FTP connections be passive (y|n) ?";
+
+}
+else {
+ $msg = "\nShould all FTP connections be passive (y|n) ?";
+}
+
+$def = $oldcfg{'ftp_int_passive'} || 0;
+
+$cfg{'ftp_int_passive'} = get_bool($msg,$def);
+
+
+#---------------------------------------------------------------------------
+
+$def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
+
+$ans = Prompt("\nWhat is your local internet domain name :",$def);
+
+$cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+If you specified some default hosts above, it is possible for me to
+do some basic tests when you run 'make test'
+
+This will cause 'make test' to be quite a bit slower and, if your
+internet connection is via dialup, will require you to be on-line
+unless the hosts are local.
+
+Do you want me to run these tests (y|n) ?
+EDQ
+
+$cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+To allow Net::FTP to be tested I will need a hostname. This host
+should allow anonymous access and have a /pub directory
+
+What host can I use :
+EDQ
+
+$cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
+ if $cfg{'test_hosts'};
+
+
+print "\n";
+
+#---------------------------------------------------------------------------
+
+my $fh = IO::File->new($libnet_cfg_out, "w") or
+ die "Cannot create '$libnet_cfg_out': $!";
+
+print "Writing $libnet_cfg_out\n";
+
+print $fh "{\n";
+
+my $key;
+foreach $key (keys %cfg) {
+ my $val = $cfg{$key};
+ if(!defined($val)) {
+ $val = "undef";
+ }
+ elsif(ref($val)) {
+ $val = '[' . join(",",
+ map {
+ my $v = "undef";
+ if(defined $_) {
+ ($v = $_) =~ s/'/\'/sog;
+ $v = "'" . $v . "'";
+ }
+ $v;
+ } @$val ) . ']';
+ }
+ else {
+ $val =~ s/'/\'/sog;
+ $val = "'" . $val . "'" if $val =~ /\D/;
+ }
+ print $fh "\t'",$key,"' => ",$val,",\n";
+}
+
+print $fh "}\n";
+
+$fh->close;
+
+############################################################################
+############################################################################
+
+exit 0;
+!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;
Property changes on: trunk/contrib/perl/utils/libnetcfg.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/perlbug.PL
===================================================================
--- trunk/contrib/perl/utils/perlbug.PL (rev 0)
+++ trunk/contrib/perl/utils/perlbug.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,1588 @@
+#!/usr/local/bin/perl
+
+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: $!";
+
+# get patchlevel.h timestamp
+
+-e catfile(updir, "patchlevel.h")
+ or die "Can't find patchlevel.h: $!";
+
+my $patchlevel_date = (stat _)[9];
+
+# TO DO (perhaps): 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("%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;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+my @patches = Config::local_patches();
+my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches;
+
+BEGIN { pop @INC if $INC[-1] eq '.' }
+use warnings;
+use strict;
+use Config;
+use File::Spec; # keep perlbug Perl 5.005 compatible
+use Getopt::Std;
+use File::Basename 'basename';
+
+sub paraprint;
+
+BEGIN {
+ eval { require Mail::Send;};
+ $::HaveSend = ($@ eq "");
+ eval { require Mail::Util; } ;
+ $::HaveUtil = ($@ eq "");
+ # use secure tempfiles wherever possible
+ eval { require File::Temp; };
+ $::HaveTemp = ($@ eq "");
+ eval { require Module::CoreList; };
+ $::HaveCoreList = ($@ eq "");
+ eval { require Text::Wrap; };
+ $::HaveWrap = ($@ eq "");
+};
+
+my $Version = "1.40";
+
+#TODO:
+# make sure failure (transmission-wise) of Mail::Send is accounted for.
+# (This may work now. Unsure of the original author's issue -JESSE 2008-06-08)
+# - Test -b option
+
+my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress,
+ $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile,
+ $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname,
+ $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD,
+ $report_about_module, $category, $severity,
+ %opt, $have_attachment, $attachments, $has_patch, $mime_boundary
+);
+
+my $running_noninteractively = !-t STDIN;
+
+my $perl_version = $^V ? sprintf("%vd", $^V) : $];
+
+my $config_tag2 = "$perl_version - $Config{cf_time}";
+
+Init();
+
+if ($opt{h}) { Help(); exit; }
+if ($opt{d}) { Dump(*STDOUT); exit; }
+if ($running_noninteractively && !$opt{t} && !($ok and not $opt{n})) {
+ paraprint <<"EOF";
+Please use $progname 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();
+if ($outfile) {
+ save_message_to_disk($outfile);
+} else {
+ Send();
+ if ($thanks) {
+ print "\nThank you for taking the time to send a thank-you message!\n\n";
+
+ paraprint <<EOF
+Please note that mailing lists are moderated, your message may take a while to
+show up.
+EOF
+ } else {
+ print "\nThank you for taking the time to file a bug report!\n\n";
+
+ paraprint <<EOF
+Please note that mailing lists are moderated, your message may take a while to
+show up. If you do not receive an automated response acknowledging your message
+within a few hours (check your SPAM folder and outgoing mail) please consider
+sending an email directly from your mail client to perlbug\@perl.org.
+EOF
+ }
+
+}
+
+exit;
+
+sub ask_for_alternatives { # (category|severity)
+ my $name = shift;
+ my %alts = (
+ 'category' => {
+ 'default' => 'core',
+ 'ok' => 'install',
+ # Inevitably some of these will end up in RT whatever we do:
+ 'thanks' => 'thanks',
+ 'opts' => [qw(core docs install library utilities)], # patch, notabug
+ },
+ 'severity' => {
+ 'default' => 'low',
+ 'ok' => 'none',
+ 'thanks' => 'none',
+ 'opts' => [qw(critical high medium low wishlist none)], # zero
+ },
+ );
+ die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts);
+ my $alt = "";
+ my $what = $ok || $thanks;
+ if ($what) {
+ $alt = $alts{$name}{$what};
+ } else {
+ my @alts = @{$alts{$name}{'opts'}};
+ print "\n\n";
+ paraprint <<EOF;
+Please pick a $name from the following list:
+
+ @alts
+EOF
+ my $err = 0;
+ do {
+ if ($err++ > 5) {
+ die "Invalid $name: aborting.\n";
+ }
+ $alt = _prompt('', "\u$name", $alts{$name}{'default'});
+ $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_Linux = lc($^O) eq 'linux';
+ $Is_OpenBSD = lc($^O) eq 'openbsd';
+
+ if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T:p:", \%opt)) { Help(); exit; };
+
+ # This comment is needed to notify metaconfig that we are
+ # using the $perladmin, $cf_by, and $cf_time definitions.
+
+ # -------- Configuration ---------
+
+ # perlbug address
+ $bugaddress = 'perlbug at perl.org';
+
+ # Test address
+ $testaddress = 'perlbug-test at perl.org';
+
+ # Thanks address
+ $thanksaddress = 'perl-thanks at perl.org';
+
+ if (basename ($0) =~ /^perlthanks/i) {
+ # invoked as perlthanks
+ $opt{T} = 1;
+ $opt{C} = 1; # don't send a copy to the local admin
+ }
+
+ if ($opt{T}) {
+ $thanks = 'thanks';
+ }
+
+ $progname = $thanks ? 'perlthanks' : 'perlbug';
+ # Target address
+ $address = $opt{a} || ($opt{t} ? $testaddress
+ : $thanks ? $thanksaddress : $bugaddress);
+
+ # Users address, used in message and in From and Reply-To headers
+ $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} || "";
+
+ # We have one or more attachments
+ $have_attachment = ($opt{p} || 0);
+ $mime_boundary = ('-' x 12) . "$Version.perlbug" if $have_attachment;
+
+ # Comma-separated list of attachments
+ $attachments = $opt{p} || "";
+ $has_patch = 0; # TBD based on file type
+
+ for my $attachment (split /\s*,\s*/, $attachments) {
+ unless (-f $attachment && -r $attachment) {
+ die "The attachment $attachment is not a readable file: $!\n";
+ }
+ $has_patch = 1 if $attachment =~ m/\.(patch|diff)$/;
+ }
+
+ # File to output to
+ $outfile = $opt{F} || "";
+
+ # Body of report
+ $body = $opt{b} || "";
+
+ # Editor
+ $ed = $opt{e} || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
+ || ($Is_VMS && "edit/tpu")
+ || ($Is_MSWin32 && "notepad")
+ || "vi";
+
+ # Not OK - provide build failure template by finessing OK report
+ if ($opt{n}) {
+ if (substr($opt{n}, 0, 2) eq 'ok' ) {
+ $opt{o} = substr($opt{n}, 1);
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # OK - send "OK" report for build on this system
+ $ok = '';
+ 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 = 'ok';
+ } 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'}
+ );
+
+ if ($::HaveUtil) {
+ $domain = Mail::Util::maildomain();
+ } elsif ($Is_MSWin32) {
+ $domain = $ENV{'USERDOMAIN'};
+ } else {
+ require Sys::Hostname;
+ $domain = Sys::Hostname::hostname();
+ }
+
+ # Message-Id - rjsf
+ $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>";
+
+ # My username
+ $me = $Is_MSWin32 ? $ENV{'USERNAME'}
+ : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
+ : eval { getpwuid($<) }; # May be missing
+
+ $from = $::Config{'cf_email'}
+ if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
+ ($me eq $::Config{'cf_by'});
+} # sub Init
+
+sub Query {
+ # Explain what perlbug is
+ unless ($ok) {
+ if ($thanks) {
+ paraprint <<'EOF';
+This program provides an easy way to send a thank-you message back to the
+authors and maintainers of perl.
+
+If you wish to submit a bug report, please run it without the -T flag
+(or run the program perlbug rather than perlthanks)
+EOF
+ } else {
+ paraprint <<"EOF";
+This program provides an easy way to create a message reporting a
+bug in the core perl distribution (along with tests or patches)
+to the volunteers who maintain perl at $address. To send a thank-you
+note to $thanksaddress instead of a bug report, please run 'perlthanks'.
+
+Please do not use $0 to send test messages, test whether perl
+works, or to report bugs in perl modules from CPAN.
+
+Suggestions for how to find help using Perl can be found at
+http://perldoc.perl.org/perlcommunity.html
+EOF
+ }
+ }
+
+ # Prompt for subject of message, if needed
+
+ if ($subject && TrivialSubject($subject)) {
+ $subject = '';
+ }
+
+ unless ($subject) {
+ print
+"First of all, please provide a subject for the message.\n";
+ if ( not $thanks) {
+ paraprint <<EOF;
+This should be a concise description of your bug or problem
+which will help the volunteers working to improve perl to categorize
+and resolve the issue. Be as specific and descriptive as
+you can. A subject like "perl bug" or "perl problem" will make it
+much less likely that your issue gets the attention it deserves.
+EOF
+ }
+
+ my $err = 0;
+ do {
+ $subject = _prompt('','Subject');
+ if ($err++ == 5) {
+ if ($thanks) {
+ $subject = 'Thanks for Perl';
+ } else {
+ die "Aborting.\n";
+ }
+ }
+ } while (TrivialSubject($subject));
+ }
+ $subject = '[PATCH] ' . $subject
+ if $has_patch && ($subject !~ m/^\[PATCH/i);
+
+ # Prompt for return address, if needed
+ unless ($opt{r}) {
+ # Try and guess return address
+ my $guess;
+
+ $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || $ENV{'EMAIL'}
+ || $from || '';
+
+ unless ($guess) {
+ # move $domain to where we can use it elsewhere
+ if ($domain) {
+ if ($Is_VMS && !$::Config{'d_socket'}) {
+ $guess = "$domain\:\:$me";
+ } else {
+ $guess = "$me\@$domain" if $domain;
+ }
+ }
+ }
+
+ if ($guess) {
+ unless ($ok) {
+ paraprint <<EOF;
+Perl's developers may need your email address to contact you for
+further information about your issue or to inform you when it is
+resolved. If the default shown is not your email address, please
+correct it.
+EOF
+ }
+ } else {
+ paraprint <<EOF;
+Please enter your full internet email address so that Perl's
+developers can contact you with questions about your issue or to
+inform you that it has been resolved.
+EOF
+ }
+
+ if ($ok && $guess) {
+ # use it
+ $from = $guess;
+ } else {
+ # verify it
+ $from = _prompt('','Your address',$guess);
+ $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} ) {
+ my $description = <<EOF;
+$0 can send a copy of this report to your local perl
+administrator. If the address below is wrong, please correct it,
+or enter 'none' or 'yourself' to not send a copy.
+EOF
+ my $entry = _prompt($description, "Local perl administrator", $cc);
+
+ if ($entry ne "") {
+ $cc = $entry;
+ $cc = '' if $me eq $cc;
+ }
+ }
+
+ $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
+ if ($cc) {
+ $andcc = " and $cc"
+ } else {
+ $andcc = ''
+ }
+
+ # Prompt for editor, if no override is given
+editor:
+ unless ($opt{e} || $opt{f} || $opt{b}) {
+
+ my $description;
+
+ chomp (my $common_end = <<"EOF");
+You will probably want to use a text editor to enter the body of
+your 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 have already composed the body of your report, you may enter
+"file", and $0 will prompt you to enter the name of the file
+containing your report.
+EOF
+
+ if ($thanks) {
+ $description = <<"EOF";
+It's now time to compose your thank-you message.
+
+Some information about your local perl configuration will automatically
+be included at the end of your message, because we're curious about
+the different ways that people build and use perl. If you'd rather
+not share this information, you're welcome to delete it.
+
+$common_end
+EOF
+ } else {
+ $description = <<"EOF";
+It's now time to compose your bug report. Try to make the report
+concise but descriptive. Please include any detail which you think
+might be relevant or might help the volunteers working to improve
+perl. If you are reporting something that does not work as you think
+it should, please try to include examples of the actual result and of
+what you expected.
+
+Some information about your local perl configuration will automatically
+be included at the end of your report. If you are using an unusual
+version of perl, it would be useful if you could confirm that you
+can replicate the problem on a standard build of perl as well.
+
+$common_end
+EOF
+ }
+
+ my $entry = _prompt($description, "Editor", $ed);
+ $usefile = 0;
+ if ($entry eq "file") {
+ $usefile = 1;
+ } elsif ($entry ne "") {
+ $ed = $entry;
+ }
+ }
+ if ($::HaveCoreList && !$ok && !$thanks) {
+ my $description = <<EOF;
+If your bug is about a Perl module rather than a core language
+feature, please enter its name here. If it's not, just hit Enter
+to skip this question.
+EOF
+
+ my $entry = '';
+ while ($entry eq '') {
+ $entry = _prompt($description, 'Module');
+ my $first_release = Module::CoreList->first_release($entry);
+ if ($entry and not $first_release) {
+ paraprint <<EOF;
+$entry is not a "core" Perl module. Please check that you entered
+its name correctly. If it is correct, quit this program, try searching
+for $entry on http://rt.cpan.org, and report your issue there.
+EOF
+
+ $entry = '';
+ } elsif (my $bug_tracker = $Module::CoreList::bug_tracker{$entry}) {
+ paraprint <<"EOF";
+$entry included with core Perl is copied directly from the CPAN distribution.
+Please report bugs in $entry directly to its maintainers using $bug_tracker
+EOF
+ $entry = '';
+ } elsif ($entry) {
+ $category ||= 'library';
+ $report_about_module = $entry;
+ last;
+ } else {
+ last;
+ }
+ }
+ }
+
+ # 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:
+ my $description = <<EOF;
+What is the name of the file that contains your report?
+EOF
+ my $entry = _prompt($description, "Filename");
+
+ if ($entry eq "") {
+ paraprint <<EOF;
+It seems you didn't enter a filename. Please choose to use a text
+editor or enter a filename.
+EOF
+ goto editor;
+ }
+
+ unless (-f $entry and -r $entry) {
+ paraprint <<EOF;
+'$entry' doesn't seem to be a readable file. You may have mistyped
+its name or may not have permission to read it.
+
+If you don't want to use a file as the content of your report, just
+hit Enter and you'll be able to select a text editor instead.
+EOF
+ goto filename;
+ }
+ $file = $entry;
+ }
+
+ # Generate report
+ open(REP, '>:raw', $filename) or die "Unable to create report file '$filename': $!\n";
+ binmode(REP, ':raw :crlf') if $Is_MSWin32;
+
+ my $reptype = !$ok ? ($thanks ? 'thank-you' : '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, '<:raw', $file)
+ or die "Unable to read report file from '$file': $!\n";
+ binmode(F, ':raw :crlf') if $Is_MSWin32;
+ while (<F>) {
+ print REP $_
+ }
+ close(F) or die "Error closing '$file': $!";
+ } else {
+ if ($thanks) {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please enter your thank-you message here]
+
+
+
+[You're welcome to delete anything below this line]
+-----------------------------------------------------------------
+EOF
+ } else {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please describe your issue here]
+
+
+
+[Please do not change anything below this line]
+-----------------------------------------------------------------
+EOF
+ }
+ }
+ Dump(*REP);
+ close(REP) or die "Error closing report file: $!";
+
+ # Set up an initial report fingerprint so we can compare it later
+ _fingerprint_lines_in_report();
+
+} # sub Query
+
+sub Dump {
+ local(*OUT) = @_;
+
+ # these won't have been set if run with -d
+ $category ||= 'core';
+ $severity ||= 'low';
+
+ print OUT <<EFF;
+---
+Flags:
+ category=$category
+ severity=$severity
+EFF
+
+ if ($has_patch) {
+ print OUT <<EFF;
+ Type=Patch
+ PatchStatus=HasPatch
+EFF
+ }
+
+ if ($report_about_module ) {
+ print OUT <<EFF;
+ module=$report_about_module
+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|CYGWIN)/, 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 = '' unless defined $value;
+ $value =~ s/'/\\'/g;
+ print OUT "$_='$value'\n";
+ }
+ }
+} # sub Dump
+
+sub Edit {
+ # Edit the report
+ if ($usefile || $body) {
+ my $description = "Please make sure that the name of the editor you want to use is correct.";
+ my $entry = _prompt($description, 'Editor', $ed);
+ $ed = $entry unless $entry eq '';
+ }
+
+ _edit_file($ed) unless $running_noninteractively;
+}
+
+sub _edit_file {
+ my $editor = shift;
+
+ my $report_written = 0;
+
+ while ( !$report_written ) {
+ my $exit_status = system("$editor $filename");
+ if ($exit_status) {
+ my $desc = <<EOF;
+The editor you chose ('$editor') could not be run!
+
+If you mistyped its name, please enter it now, otherwise just press Enter.
+EOF
+ my $entry = _prompt( $desc, 'Editor', $editor );
+ if ( $entry ne "" ) {
+ $editor = $entry;
+ next;
+ } else {
+ paraprint <<EOF;
+You may want to save your report to a file, so you can edit and
+mail it later.
+EOF
+ return;
+ }
+ }
+ return if ( $ok and not $opt{n} ) || $body;
+
+ # Check that we have a report that has some, eh, report in it.
+
+ unless ( _fingerprint_lines_in_report() ) {
+ my $description = <<EOF;
+It looks like you didn't enter a report. You may [r]etry your edit
+or [c]ancel this report.
+EOF
+ my $action = _prompt( $description, "Action (Retry/Cancel) " );
+ if ( $action =~ /^[re]/i ) { # <R>etry <E>dit
+ next;
+ } elsif ( $action =~ /^[cq]/i ) { # <C>ancel, <Q>uit
+ Cancel(); # cancel exits
+ }
+ }
+ # Ok. the user did what they needed to;
+ return;
+
+ }
+}
+
+
+sub Cancel {
+ 1 while unlink($filename); # remove all versions under VMS
+ print "\nQuitting without sending your message.\n";
+ exit(0);
+}
+
+sub NowWhat {
+ # Report is done, prompt for further action
+ if( !$opt{S} ) {
+ while(1) {
+ my $menu = <<EOF;
+
+
+You have finished composing your message. At this point, you have
+a few options. You can:
+
+ * [Se]nd the message to $address$andcc,
+ * [D]isplay the message on the screen,
+ * [R]e-edit the message
+ * Display or change the message's [su]bject
+ * Save the message to a [f]ile to mail at another time
+ * [Q]uit without sending a message
+
+EOF
+ retry:
+ print $menu;
+ my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)",
+ $opt{t} ? 'q' : '');
+ print "\n";
+ if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
+ if ( SaveMessage() ) { exit }
+ } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
+ # Display the message
+ print _read_report($filename);
+ if ($have_attachment) {
+ print "\n\n---\nAttachment(s):\n";
+ for my $att (split /\s*,\s*/, $attachments) { print " $att\n"; }
+ }
+ } elsif ($action =~ /^su/i) { # <Su>bject
+ my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject");
+ if ($reply ne '') {
+ unless (TrivialSubject($reply)) {
+ $subject = $reply;
+ print "Subject: $subject\n";
+ }
+ }
+ } elsif ($action =~ /^se/i) { # <S>end
+ # Send the message
+ my $reply = _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no');
+ if ($reply =~ /^yes$/) {
+ last;
+ } else {
+ paraprint <<EOF;
+You didn't type "yes", so your message has not yet been sent.
+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;
+The command you entered was ambiguous. Please type "send", "save" or "subject".
+EOF
+ }
+ }
+ }
+} # sub NowWhat
+
+sub TrivialSubject {
+ my $subject = shift;
+ if ($subject =~
+ /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
+ length($subject) < 4 ||
+ ($subject !~ /\s/ && ! $opt{t})) { # non-whitespace is accepted in test mode
+ print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n";
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub SaveMessage {
+ my $file_save = $outfile || "$progname.rep";
+ my $file = _prompt( '', "Name of file to save message in", $file_save );
+ save_message_to_disk($file) || return undef;
+ print "\n";
+ paraprint <<EOF;
+A copy of your message has been saved in '$file' for you to
+send to '$address' with your normal mail client.
+EOF
+}
+
+sub Send {
+
+ # Message has been accepted for transmission -- Send the message
+
+ # on linux certain "mail" implementations won't accept the subject
+ # as "~s subject" and thus the Subject header will be corrupted
+ # so don't use Mail::Send to be safe
+ eval {
+ if ( $::HaveSend && !$Is_Linux && !$Is_OpenBSD ) {
+ _send_message_mailsend();
+ } elsif ($Is_VMS) {
+ _send_message_vms();
+ } else {
+ _send_message_sendmail();
+ }
+ };
+
+ if ( my $error = $@ ) {
+ paraprint <<EOF;
+$0 has detected an error while trying to send your message: $error.
+
+Your message may not have been sent. You will now have a chance to save a copy to disk.
+EOF
+ SaveMessage();
+ return;
+ }
+
+ 1 while unlink($filename); # remove all versions under VMS
+} # sub Send
+
+sub Help {
+ print <<EOF;
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run "$0" interactively from a command
+line without any special arguments and follow the prompts.
+
+Advanced usage:
+
+$0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
+ [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
+ [-p patchfile ]
+$0 [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
+
+
+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.
+ -p File containing a patch or other text attachment. Separate
+ multiple files with commas.
+ -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'.
+ -T Thank-you mode. The target address defaults to '$thanksaddress'.
+ -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 {
+ if ($::HaveTemp) {
+ # Good. Use a secure temp file
+ my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
+ close($fh);
+ return $filename;
+ } else {
+ # Bah. Fall back to doing things less securely.
+ 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,}/, "@_";
+ for (@paragraphs) { # implicit local $_
+ s/(\S)\s*\n/$1 /g;
+ write;
+ print "\n";
+ }
+}
+
+sub _prompt {
+ my ($explanation, $prompt, $default) = (@_);
+ if ($explanation) {
+ print "\n\n";
+ paraprint $explanation;
+ }
+ print $prompt. ($default ? " [$default]" :''). ": ";
+ my $result = scalar(<>);
+ return $default if !defined $result; # got eof
+ chomp($result);
+ $result =~ s/^\s*(.*?)\s*$/$1/s;
+ if ($default && $result eq '') {
+ return $default;
+ } else {
+ return $result;
+ }
+}
+
+sub _build_header {
+ my %attr = (@_);
+
+ my $head = '';
+ for my $header (keys %attr) {
+ $head .= "$header: ".$attr{$header}."\n";
+ }
+ return $head;
+}
+
+sub _message_headers {
+ my %headers = ( To => $address, Subject => $subject );
+ $headers{'Cc'} = $cc if ($cc);
+ $headers{'Message-Id'} = $messageid if ($messageid);
+ $headers{'Reply-To'} = $from if ($from);
+ $headers{'From'} = $from if ($from);
+ if ($have_attachment) {
+ $headers{'MIME-Version'} = '1.0';
+ $headers{'Content-Type'} = qq{multipart/mixed; boundary=\"$mime_boundary\"};
+ }
+ return \%headers;
+}
+
+sub _add_body_start {
+ my $body_start = <<"BODY_START";
+This is a multi-part message in MIME format.
+--$mime_boundary
+Content-Type: text/plain; format=fixed
+Content-Transfer-Encoding: 8bit
+
+BODY_START
+ return $body_start;
+}
+
+sub _add_attachments {
+ my $attach = '';
+ for my $attachment (split /\s*,\s*/, $attachments) {
+ my $attach_file = basename($attachment);
+ $attach .= <<"ATTACHMENT";
+
+--$mime_boundary
+Content-Type: text/x-patch; name="$attach_file"
+Content-Transfer-Encoding: 8bit
+Content-Disposition: attachment; filename="$attach_file"
+
+ATTACHMENT
+
+ open my $attach_fh, '<:raw', $attachment
+ or die "Couldn't open attachment '$attachment': $!\n";
+ while (<$attach_fh>) { $attach .= $_; }
+ close($attach_fh) or die "Error closing attachment '$attachment': $!";
+ }
+
+ $attach .= "\n--$mime_boundary--\n";
+ return $attach;
+}
+
+sub _read_report {
+ my $fname = shift;
+ my $content;
+ open( REP, "<:raw", $fname ) or die "Couldn't open file '$fname': $!\n";
+ binmode(REP, ':raw :crlf') if $Is_MSWin32;
+ # wrap long lines to make sure the report gets delivered
+ local $Text::Wrap::columns = 900;
+ local $Text::Wrap::huge = 'overflow';
+ while (<REP>) {
+ if ($::HaveWrap && /\S/) { # wrap() would remove empty lines
+ $content .= Text::Wrap::wrap(undef, undef, $_);
+ } else {
+ $content .= $_;
+ }
+ }
+ close(REP) or die "Error closing report file '$fname': $!";
+ return $content;
+}
+
+sub build_complete_message {
+ my $content = _build_header(%{_message_headers()}) . "\n\n";
+ $content .= _add_body_start() if $have_attachment;
+ $content .= _read_report($filename);
+ $content .= _add_attachments() if $have_attachment;
+ return $content;
+}
+
+sub save_message_to_disk {
+ my $file = shift;
+
+ open OUTFILE, '>:raw', $file or do { warn "Couldn't open '$file': $!\n"; return undef};
+ binmode(OUTFILE, ':raw :crlf') if $Is_MSWin32;
+
+ print OUTFILE build_complete_message();
+ close(OUTFILE) or do { warn "Error closing $file: $!"; return undef };
+ print "\nMessage saved.\n";
+ return 1;
+}
+
+sub _send_message_vms {
+
+ my $mail_from = $from;
+ my $rcpt_to_to = $address;
+ my $rcpt_to_cc = $cc;
+
+ map { $_ =~ s/^[^<]*<//;
+ $_ =~ s/>[^>]*//; } ($mail_from, $rcpt_to_to, $rcpt_to_cc);
+
+ if ( open my $sff_fh, '|-:raw', 'MCR TCPIP$SYSTEM:TCPIP$SMTP_SFF.EXE SYS$INPUT:' ) {
+ print $sff_fh "MAIL FROM:<$mail_from>\n";
+ print $sff_fh "RCPT TO:<$rcpt_to_to>\n";
+ print $sff_fh "RCPT TO:<$rcpt_to_cc>\n" if $rcpt_to_cc;
+ print $sff_fh "DATA\n";
+ print $sff_fh build_complete_message();
+ my $success = close $sff_fh;
+ if ($success ) {
+ print "\nMessage sent\n";
+ return;
+ }
+ }
+ die "Mail transport failed (leaving bug report in $filename): $^E\n";
+}
+
+sub _send_message_mailsend {
+ my $msg = Mail::Send->new();
+ my %headers = %{_message_headers()};
+ for my $key ( keys %headers) {
+ $msg->add($key => $headers{$key});
+ }
+
+ $fh = $msg->open;
+ binmode($fh, ':raw');
+ print $fh _add_body_start() if $have_attachment;
+ print $fh _read_report($filename);
+ print $fh _add_attachments() if $have_attachment;
+ $fh->close or die "Error sending mail: $!";
+
+ print "\nMessage sent.\n";
+}
+
+sub _probe_for_sendmail {
+ 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";
+ }
+ }
+ return $sendmail;
+}
+
+sub _send_message_sendmail {
+ my $sendmail = _probe_for_sendmail();
+ unless ($sendmail) {
+ my $message_start = !$Is_Linux && !$Is_OpenBSD ? <<'EOT' : <<'EOT';
+It appears that there is no program which looks like "sendmail" on
+your system and that the Mail::Send library from CPAN isn't available.
+EOT
+It appears that there is no program which looks like "sendmail" on
+your system.
+EOT
+ paraprint(<<"EOF"), die "\n";
+$message_start
+Because of this, there's no easy way to automatically send your
+message.
+
+A copy of your message has been saved in '$filename' for you to
+send to '$address' with your normal mail client.
+EOF
+ }
+
+ open( SENDMAIL, "|-:raw", $sendmail, "-t", "-oi", "-f", $from )
+ || die "'|$sendmail -t -oi -f $from' failed: $!";
+ print SENDMAIL build_complete_message();
+ if ( close(SENDMAIL) ) {
+ print "\nMessage sent\n";
+ } else {
+ warn "\nSendmail returned status '", $? >> 8, "'\n";
+ }
+}
+
+
+
+# a strange way to check whether any significant editing
+# has been done: check whether any new non-empty lines
+# have been added.
+
+sub _fingerprint_lines_in_report {
+ my $new_lines = 0;
+ # read in the report template once so that
+ # we can track whether the user does any editing.
+ # yes, *all* whitespace is ignored.
+
+ open(REP, '<:raw', $filename) or die "Unable to open report file '$filename': $!\n";
+ binmode(REP, ':raw :crlf') if $Is_MSWin32;
+ while (my $line = <REP>) {
+ $line =~ s/\s+//g;
+ $new_lines++ if (!$REP{$line});
+
+ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ # returns the number of lines with content that wasn't there when last we looked
+ return $new_lines;
+}
+
+
+
+format STDOUT =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
+$_
+.
+
+__END__
+
+=head1 NAME
+
+perlbug - how to submit bug reports on Perl
+
+=head1 SYNOPSIS
+
+B<perlbug>
+
+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> ]> S<[ B<-T> ]>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
+ S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+
+B<perlthanks>
+
+=head1 DESCRIPTION
+
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run it interactively from a command
+line without any special arguments and follow the prompts.
+
+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-core module (such as Tk, DBI, etc), then please see the
+documentation that came with that distribution to determine the
+correct place to report bugs.
+
+If you are unable to send your report using B<perlbug> (most likely
+because your system doesn't have a way to send mail that perlbug
+recognizes), you may be able to use this tool to compose your report
+and save it to a file which you can then send to B<perlbug at perl.org>
+using your regular mail client.
+
+In extreme cases, B<perlbug> may not work well enough on your system
+to guide you through composing a bug report. In those cases, you
+may be able to use B<perlbug -d> to get system configuration
+information to include in a manually composed bug report to
+B<perlbug at perl.org>.
+
+
+When reporting a bug, please 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.org/ to find out. If you are not using the
+latest released version, please try to replicate your bug on the
+latest stable release.
+
+Note that reports about bugs in old versions of Perl, especially
+those which indicate you haven't also tested the current stable
+release of Perl, are likely to receive less attention from the
+volunteers who build and maintain Perl than reports about bugs in
+the current release.
+
+This tool isn't appropriate for reporting bugs in any version
+prior to Perl 5.0.
+
+=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 issue you've run into
+isn't intentional by glancing through the documentation that comes
+with the Perl distribution.
+
+Given the sheer volume of Perl documentation, this isn't a trivial
+undertaking, but if you can point to documentation that suggests
+the behaviour you're seeing is I<wrong>, your issue is likely to
+receive more attention. You may want to start with B<perldoc>
+L<perltrap> for pointers to common traps that new (and experienced)
+Perl programmers run into.
+
+If you're unsure of the meaning of an error message you've run
+across, B<perldoc> L<perldiag> for an explanation. If the message
+isn't in perldiag, it probably isn't generated by Perl. You may
+have luck consulting your operating system documentation instead.
+
+If you are on a non-UNIX platform B<perldoc> L<perlport>, as some
+features may be unimplemented or work differently.
+
+You may be able to figure out what's going wrong using the Perl
+debugger. For information about how to use the debugger B<perldoc>
+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 -- if nobody can duplicate your problem, it probably won't be
+addressed.
+
+A good test case has most of these attributes: short, simple code;
+few dependencies on external commands, modules, or libraries; no
+platform-dependent code (unless it's a platform-specific bug);
+clear, simple documentation.
+
+A good test case is almost always a good candidate to be included in
+Perl's test suite. If you have the time, consider writing your test case so
+that it can be easily included into the standard test suite.
+
+=item Have you included all relevant information?
+
+Be sure to include the B<exact> error messages, if any.
+"Perl gave an error" 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 crash 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. Any insight you can provide into the problem
+will help 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?
+
+If so, that's great news; bug reports with patches are likely to
+receive significantly more attention and interest than those without
+patches. Please attach your patch to the report using the C<-p> option.
+When sending a patch, create it using C<git format-patch> if possible,
+though a unified diff created with C<diff -pu> will do nearly as well.
+
+Your patch may be returned with requests for changes, or requests for more
+detailed explanations about your fix.
+
+Here are a few hints for creating high-quality patches:
+
+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 C<git am> or 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 is covered
+by Perl's test suite).
+
+=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 at 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" is not informative. Neither
+is "perl crashes" nor is "HELP!!!". These don't help. A compact
+description of what's wrong is fine.
+
+=item Can you use C<perlbug> to submit a thank-you note?
+
+Yes, you can do this by either using the C<-T> option, or by invoking
+the program as C<perlthanks>. Thank-you notes are good. It makes people
+smile.
+
+=back
+
+Having done your bit, please be prepared to wait, to be told the
+bug is in your code, or possibly to get no reply at all. The
+volunteers who maintain Perl are busy folks, so if your problem is
+an obvious bug in your own code, is difficult to understand or is
+a duplicate of an existing report, you may not receive a personal
+reply.
+
+If it is important to you that your bug be fixed, do monitor the
+perl5-porters at perl.org mailing list (mailing lists are moderated, your
+message may take a while to show up) and the commit logs to development
+versions of Perl, and encourage the maintainers with kind words or
+offers of frosty beverages. (Please do be kind to the maintainers.
+Harassing or flaming them is likely to have the opposite effect of the
+one you want.)
+
+Feel free to update the ticket about your bug on http://rt.perl.org
+if a new version of Perl is released and your bug is still present.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-a>
+
+Address to send the report to. Defaults to B<perlbug at 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<-p>
+
+The names of one or more patch files or other text attachments to be
+included with the report. Multiple files must be separated with commas.
+
+=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 B<perlbug-test at perl.org>.
+Also makes it possible to command perlbug from a pipe or file, for
+testing purposes.
+
+=item B<-T>
+
+Send a thank-you note instead of a bug report.
+
+=item B<-v>
+
+Include verbose configuration data in the report.
+
+=back
+
+=head1 AUTHORS
+
+Kenneth Albanowski (E<lt>kjahds at kjahds.comE<gt>), subsequently
+I<doc>tored by Gurusamy Sarathy (E<lt>gsar at activestate.comE<gt>),
+Tom Christiansen (E<lt>tchrist at perl.comE<gt>), Nathan Torkington
+(E<lt>gnat at frii.comE<gt>), Charles F. Randall (E<lt>cfr at pobox.comE<gt>),
+Mike Guy (E<lt>mjtg at cam.ac.ukE<gt>), Dominic Dunlop
+(E<lt>domo at computer.orgE<gt>), Hugo van der Sanden (E<lt>hv at crypt.orgE<gt>),
+Jarkko Hietaniemi (E<lt>jhi at iki.fiE<gt>), Chris Nandor
+(E<lt>pudge at pobox.comE<gt>), Jon Orwant (E<lt>orwant at media.mit.eduE<gt>,
+Richard Foley (E<lt>richard.foley at rfi.netE<gt>), Jesse Vincent
+(E<lt>jesse at bestpractical.comE<gt>), and Craig A. Berry (E<lt>craigberry at mac.comE<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;
Property changes on: trunk/contrib/perl/utils/perlbug.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/perldoc.PL
===================================================================
--- trunk/contrib/perl/utils/perldoc.PL (rev 0)
+++ trunk/contrib/perl/utils/perldoc.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,61 @@
+#!/usr/local/bin/perl
+
+# This is for generating the perldoc executable.
+# It may eventually be expanded to generate many executables, as
+# explained in the preface of /Programming Perl/ 3e.
+
+require 5;
+use strict;
+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');
+my $file_shortname = $file; # should be like "perldoc", maybe "perlsyn", etc.
+warn "How odd, I'm going to generate $file_shortname?!"
+ unless $file_shortname =~ m/^\w+$/;
+
+$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;
+
+# This "$file" file was generated by "$0"
+
+require 5;
+BEGIN {
+ \$^W = 1 if \$ENV{'PERLDOCDEBUG'};
+ pop \@INC if \$INC[-1] eq '.';
+}
+use Pod::Perldoc;
+exit( Pod::Perldoc->run() );
+
+!GROK!THIS!
+
+
+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;
+
Property changes on: trunk/contrib/perl/utils/perldoc.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/perlivp.PL
===================================================================
--- trunk/contrib/perl/utils/perlivp.PL (rev 0)
+++ trunk/contrib/perl/utils/perlivp.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,456 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename;
+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.
+my $origdir = cwd;
+chdir dirname($0);
+my $file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+# 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!
+
+print OUT "\n# perlivp $^V\n";
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
+sub usage {
+ warn "@_\n" if @_;
+ print << " EOUSAGE";
+Usage:
+
+ $0 [-p] [-v] | [-h]
+
+ -p Print a preface before each test telling what it will test.
+ -v Verbose mode in which extra information about test results
+ is printed. Test failures always print out some extra information
+ regardless of whether or not this switch is set.
+ -h Prints this help message.
+ EOUSAGE
+ exit;
+}
+
+use vars qw(%opt); # allow testing with older versions (do not use our)
+
+ at opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0);
+
+while ($ARGV[0] =~ /^-/) {
+ $ARGV[0] =~ s/^-//;
+ for my $flag (split(//,$ARGV[0])) {
+ usage() if '?' =~ /\Q$flag/;
+ usage() if 'h' =~ /\Q$flag/;
+ usage() if 'H' =~ /\Q$flag/;
+ usage("unknown flag: '$flag'") unless 'HhPpVv' =~ /\Q$flag/;
+ warn "$0: '$flag' flag already set\n" if $opt{$flag}++;
+ }
+ shift;
+}
+
+$opt{p}++ if $opt{P};
+$opt{v}++ if $opt{V};
+
+my $pass__total = 0;
+my $error_total = 0;
+my $tests_total = 0;
+
+!NO!SUBS!
+
+# We cannot merely check the variable '$^X' in general since on many
+# Unixes it is the basename rather than the full path to the perl binary.
+my $perlpath = '';
+if (defined($Config{'perlpath'})) { $perlpath = $Config{'perlpath'}; }
+
+# The useithreads Config variable plays a role in whether or not
+# threads and threads/shared work when C<use>d. They apparently always
+# get installed on systems that can run Configure.
+my $useithreads = '';
+if (defined($Config{'useithreads'})) { $useithreads = $Config{'useithreads'}; }
+
+print OUT <<"!GROK!THIS!";
+my \$perlpath = '$perlpath';
+my \$useithreads = '$useithreads';
+!GROK!THIS!
+
+print OUT <<'!NO!SUBS!';
+
+print "## Checking Perl binary via variable '\$perlpath' = $perlpath.\n" if $opt{'p'};
+
+my $label = 'Executable perl binary';
+
+if (-x $perlpath) {
+ print "## Perl binary '$perlpath' appears executable.\n" if $opt{'v'};
+ print "ok 1 $label\n";
+ $pass__total++;
+}
+else {
+ print "# Perl binary '$perlpath' does not appear executable.\n";
+ print "not ok 1 $label\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking Perl version via variable '\$]'.\n" if $opt{'p'};
+
+!NO!SUBS!
+
+print OUT <<"!GROK!THIS!";
+my \$ivp_VERSION = "$]";
+
+!GROK!THIS!
+print OUT <<'!NO!SUBS!';
+
+$label = 'Perl version correct';
+if ($ivp_VERSION eq $]) {
+ print "## Perl version '$]' appears installed as expected.\n" if $opt{'v'};
+ print "ok 2 $label\n";
+ $pass__total++;
+}
+else {
+ print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
+ print "not ok 2 $label\n";
+ $error_total++;
+}
+$tests_total++;
+
+# We have the right perl and version, so now reset @INC so we ignore
+# PERL5LIB and '.'
+{
+ local $ENV{PERL5LIB};
+ my $perl_V = qx($perlpath -V);
+ $perl_V =~ s{.*\@INC:\n}{}ms;
+ @INC = grep { length && $_ ne '.' } split ' ', $perl_V;
+}
+
+print "## Checking roots of the Perl library directory tree via variable '\@INC'.\n" if $opt{'p'};
+
+my $INC_total = 0;
+my $INC_there = 0;
+foreach (@INC) {
+ next if $_ eq '.'; # skip -d test here
+ if (-d $_) {
+ print "## Perl \@INC directory '$_' exists.\n" if $opt{'v'};
+ $INC_there++;
+ }
+ else {
+ print "# Perl \@INC directory '$_' does not appear to exist.\n";
+ }
+ $INC_total++;
+}
+
+$label = '@INC directoreis exist';
+if ($INC_total == $INC_there) {
+ print "ok 3 $label\n";
+ $pass__total++;
+}
+else {
+ print "not ok 3 $label\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'};
+
+my $needed_total = 0;
+my $needed_there = 0;
+foreach (qw(Config.pm ExtUtils/Installed.pm)) {
+ $@ = undef;
+ $needed_total++;
+ eval "require \"$_\";";
+ if (!$@) {
+ print "## Module '$_' appears to be installed.\n" if $opt{'v'};
+ $needed_there++;
+ }
+ else {
+ print "# Needed module '$_' does not appear to be properly installed.\n";
+ }
+ $@ = undef;
+}
+$label = 'Modules needed for rest of perlivp exist';
+if ($needed_total == $needed_there) {
+ print "ok 4 $label\n";
+ $pass__total++;
+}
+else {
+ print "not ok 4 $label\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of extensions built with perl.\n" if $opt{'p'};
+
+use Config;
+
+my $extensions_total = 0;
+my $extensions_there = 0;
+if (defined($Config{'extensions'})) {
+ my @extensions = split(/\s+/,$Config{'extensions'});
+ foreach (@extensions) {
+ next if ($_ eq '');
+ if ( $useithreads !~ /define/i ) {
+ next if ($_ eq 'threads');
+ next if ($_ eq 'threads/shared');
+ }
+ # that's a distribution name, not a module name
+ next if $_ eq 'IO/Compress';
+ next if $_ eq 'Devel/DProf';
+ next if $_ eq 'libnet';
+ next if $_ eq 'Locale/Codes';
+ next if $_ eq 'podlators';
+ next if $_ eq 'perlfaq';
+ # test modules
+ next if $_ eq 'XS/APItest';
+ next if $_ eq 'XS/Typemap';
+ # VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
+ # \NT> perl -e "eval \"require './Devel/DProf.pm'\"; print $@"
+ # DProf: run perl with -d to use DProf.
+ # Compilation failed in require at (eval 1) line 1.
+ eval " require \"$_.pm\"; ";
+ if (!$@) {
+ print "## Module '$_' appears to be installed.\n" if $opt{'v'};
+ $extensions_there++;
+ }
+ else {
+ print "# Required module '$_' does not appear to be properly installed.\n";
+ $@ = undef;
+ }
+ $extensions_total++;
+ }
+
+ # A silly name for a module (that hopefully won't ever exist).
+ # Note that this test serves more as a check of the validity of the
+ # actual required module tests above.
+ my $unnecessary = 'bLuRfle';
+
+ if (!grep(/$unnecessary/, @extensions)) {
+ $@ = undef;
+ eval " require \"$unnecessary.pm\"; ";
+ if ($@) {
+ print "## Unnecessary module '$unnecessary' does not appear to be installed.\n" if $opt{'v'};
+ }
+ else {
+ print "# Unnecessary module '$unnecessary' appears to be installed.\n";
+ $extensions_there++;
+ }
+ }
+ $@ = undef;
+}
+$label = 'All (and only) expected extensions installed';
+if ($extensions_total == $extensions_there) {
+ print "ok 5 $label\n";
+ $pass__total++;
+}
+else {
+ print "not ok 5 $label\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of later additional extensions.\n" if $opt{'p'};
+
+use ExtUtils::Installed;
+
+my $installed_total = 0;
+my $installed_there = 0;
+my $version_check = 0;
+my $installed = ExtUtils::Installed -> new();
+my @modules = $installed -> modules();
+my @missing = ();
+my $version = undef;
+for (@modules) {
+ $installed_total++;
+ # Consider it there if it contains one or more files,
+ # and has zero missing files,
+ # and has a defined version
+ $version = undef;
+ $version = $installed -> version($_);
+ if ($version) {
+ print "## $_; $version\n" if $opt{'v'};
+ $version_check++;
+ }
+ else {
+ print "# $_; NO VERSION\n" if $opt{'v'};
+ }
+ $version = undef;
+ @missing = ();
+ @missing = $installed -> validate($_);
+
+ # .bs files are optional
+ @missing = grep { ! /\.bs$/ } @missing;
+ # man files are often compressed
+ @missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing;
+
+ if ($#missing >= 0) {
+ print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
+ print '# ',join(' ', at missing),"\n";
+ }
+ elsif ($#missing == -1) {
+ $installed_there++;
+ }
+ @missing = ();
+}
+$label = 'Module files correctly installed';
+if (($installed_total == $installed_there) &&
+ ($installed_total == $version_check)) {
+ print "ok 6 $label\n";
+ $pass__total++;
+}
+else {
+ print "not ok 6 $label\n";
+ $error_total++;
+}
+$tests_total++;
+
+# Final report (rather than feed ousrselves to Test::Harness::runtests()
+# we simply format some output on our own to keep things simple and
+# easier to "fix" - at least for now.
+
+if ($error_total == 0 && $tests_total) {
+ print "All tests successful.\n";
+} elsif ($tests_total==0){
+ die "FAILED--no tests were run for some reason.\n";
+} else {
+ my $rate = 0.0;
+ if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); }
+ printf " %d/%d subtests failed, %.2f%% okay.\n",
+ $error_total, $tests_total, $rate;
+}
+
+=head1 NAME
+
+perlivp - Perl Installation Verification Procedure
+
+=head1 SYNOPSIS
+
+B<perlivp> [B<-p>] [B<-v>] [B<-h>]
+
+=head1 DESCRIPTION
+
+The B<perlivp> program is set up at Perl source code build time to test the
+Perl version it was built under. It can be used after running:
+
+ make install
+
+(or your platform's equivalent procedure) to verify that B<perl> and its
+libraries have been installed correctly. A correct installation is verified
+by output that looks like:
+
+ ok 1
+ ok 2
+
+etc.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-h> help
+
+Prints out a brief help message.
+
+=item B<-p> print preface
+
+Gives a description of each test prior to performing it.
+
+=item B<-v> verbose
+
+Gives more detailed information about each test, after it has been performed.
+Note that any failed tests ought to print out some extra information whether
+or not -v is thrown.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item * print "# Perl binary '$perlpath' does not appear executable.\n";
+
+Likely to occur for a perl binary that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
+
+Likely to occur for a perl that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Perl \@INC directory '$_' does not appear to exist.\n";
+
+Likely to occur for a perl library tree that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Needed module '$_' does not appear to be properly installed.\n";
+
+One of the two modules that is used by perlivp was not present in the
+installation. This is a serious error since it adversely affects perlivp's
+ability to function. You may be able to correct this by performing a
+proper perl installation.
+
+=item * print "# Required module '$_' does not appear to be properly installed.\n";
+
+An attempt to C<eval "require $module"> failed, even though the list of
+extensions indicated that it should succeed. Correct by conducting a proper
+installation.
+
+=item * print "# Unnecessary module 'bLuRfle' appears to be installed.\n";
+
+This test not coming out ok could indicate that you have in fact installed
+a bLuRfle.pm module or that the C<eval " require \"$module_name.pm\"; ">
+test may give misleading results with your installation of perl. If yours
+is the latter case then please let the author know.
+
+=item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
+
+One or more files turned up missing according to a run of
+C<ExtUtils::Installed -E<gt> validate()> over your installation.
+Correct by conducting a proper installation.
+
+=back
+
+For further information on how to conduct a proper installation consult the
+INSTALL file that comes with the perl source and the README file for your
+platform.
+
+=head1 AUTHOR
+
+Peter Prymmer
+
+=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;
+
Property changes on: trunk/contrib/perl/utils/perlivp.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/piconv.PL
===================================================================
--- trunk/contrib/perl/utils/piconv.PL (rev 0)
+++ trunk/contrib/perl/utils/piconv.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,48 @@
+#!/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!
+
+use File::Spec;
+
+my $piconv = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "cpan", "Encode", "bin"), "piconv");
+
+if (open(PICONV, '<', $piconv)) {
+ print OUT <PICONV>;
+ close PICONV;
+} else {
+ die "$0: cannot find '$piconv'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/piconv.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/pl2pm.PL
===================================================================
--- trunk/contrib/perl/utils/pl2pm.PL (rev 0)
+++ trunk/contrib/perl/utils/pl2pm.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,417 @@
+#!/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 at wall.org>
+
+=cut
+
+use strict;
+use warnings;
+
+my %keyword = ();
+
+while (<DATA>) {
+ chomp;
+ $keyword{$_} = 1;
+}
+
+local $/;
+
+while (<>) {
+ my $newname = $ARGV;
+ $newname =~ s/\.pl$/.pm/ || next;
+ $newname =~ s#(.*/)?(\w+)#$1\u$2#;
+ if (-f $newname) {
+ warn "Won't overwrite existing $newname\n";
+ next;
+ }
+ my $oldpack = $2;
+ my $newpack = "\u$2";
+ my @export = ();
+
+ 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+\w+'/) {
+ @export = m/sub\s+\w+'(\w+)/g;
+ s/(sub\s+)main'(\w+)/$1$2/g;
+ }
+ else {
+ @export = m/sub\s+([A-Za-z]\w*)/g;
+ }
+ my @export_ok = grep($keyword{$_}, @export);
+ @export = grep(!$keyword{$_}, @export);
+
+ my %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,$newpack,$oldpack,\%export)/eg;
+ s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/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;
+
+ my $export_ok = '';
+ my $carp ='';
+
+
+ if (s/\bdie\b/croak/g) {
+ $carp = "use Carp;\n";
+ s/croak "([^"]*)\\n"/croak "$1"/g;
+ }
+
+ if (@export_ok) {
+ $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
+ }
+
+ if ( open(PM, ">", $newname) ) {
+ print PM <<"END";
+package $newpack;
+use 5.006;
+require Exporter;
+$carp
+\@ISA = qw(Exporter);
+\@EXPORT = qw(@export);
+$export_ok
+$_
+END
+ }
+ else {
+ warn "Can't create $newname: $!\n";
+ }
+}
+
+sub xlate {
+ my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
+
+ my $xlated ;
+ if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
+ $xlated = "${pack}'$ident";
+ }
+ elsif ($pack eq '' || $pack eq 'main') {
+ if ($export->{$ident}) {
+ $xlated = "$prefix$ident";
+ }
+ else {
+ $xlated = "$prefix${pack}::$ident";
+ }
+ }
+ elsif ($pack eq $oldpack) {
+ $xlated = "$prefix${newpack}::$ident";
+ }
+ else {
+ $xlated = "$prefix${pack}::$ident";
+ }
+
+ return $xlated;
+}
+__END__
+AUTOLOAD
+BEGIN
+CHECK
+CORE
+DESTROY
+END
+INIT
+UNITCHECK
+abs
+accept
+alarm
+and
+atan2
+bind
+binmode
+bless
+caller
+chdir
+chmod
+chomp
+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
+exists
+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
+lock
+log
+lstat
+lt
+m
+map
+mkdir
+msgctl
+msgget
+msgrcv
+msgsnd
+my
+ne
+next
+no
+not
+oct
+open
+opendir
+or
+ord
+our
+pack
+package
+pipe
+pop
+pos
+print
+printf
+prototype
+push
+q
+qq
+qr
+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
+sysopen
+sysread
+sysseek
+system
+syswrite
+tell
+telldir
+tie
+tied
+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;
Property changes on: trunk/contrib/perl/utils/pl2pm.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/pod2html.PL
===================================================================
--- trunk/contrib/perl/utils/pod2html.PL (rev 0)
+++ trunk/contrib/perl/utils/pod2html.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,53 @@
+#!/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!
+
+use File::Spec;
+
+my $script = File::Spec->catfile(
+ File::Spec->catdir(
+ File::Spec->updir, qw(ext Pod-Html bin),
+ ),
+ 'pod2html',
+);
+
+if (open(IN, $script)) {
+ print OUT <IN>;
+ close IN;
+} else {
+ die "$0: cannot find '$script'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/pod2html.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/prove.PL
===================================================================
--- trunk/contrib/perl/utils/prove.PL (rev 0)
+++ trunk/contrib/perl/utils/prove.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,49 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. 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!
+
+use File::Spec;
+
+my $prove = File::Spec->catfile(File::Spec->catdir(File::Spec->updir,
+ "cpan", "Test-Harness", "bin"), "prove");
+
+if (open(PROVE, '<', $prove)) {
+ print OUT <PROVE>;
+ close PROVE;
+} else {
+ die "$0: cannot find '$prove'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/prove.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/ptar.PL
===================================================================
--- trunk/contrib/perl/utils/ptar.PL (rev 0)
+++ trunk/contrib/perl/utils/ptar.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $script = File::Spec->catfile(
+ File::Spec->catdir(
+ File::Spec->updir, qw[cpan Archive-Tar bin]
+ ), "ptar");
+
+if (open(IN, '<', $script)) {
+ print OUT <IN>;
+ close IN;
+} else {
+ die "$0: cannot find '$script'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/ptar.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/ptardiff.PL
===================================================================
--- trunk/contrib/perl/utils/ptardiff.PL (rev 0)
+++ trunk/contrib/perl/utils/ptardiff.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $script = File::Spec->catfile(
+ File::Spec->catdir(
+ File::Spec->updir, qw[cpan Archive-Tar bin]
+ ), "ptardiff");
+
+if (open(IN, '<', $script)) {
+ print OUT <IN>;
+ close IN;
+} else {
+ die "$0: cannot find '$script'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/ptardiff.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/ptargrep.PL
===================================================================
--- trunk/contrib/perl/utils/ptargrep.PL (rev 0)
+++ trunk/contrib/perl/utils/ptargrep.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $script = File::Spec->catfile(
+ File::Spec->catdir(
+ File::Spec->updir, qw[cpan Archive-Tar bin]
+ ), "ptargrep");
+
+if (open(IN, '<', $script)) {
+ print OUT <IN>;
+ close IN;
+} else {
+ die "$0: cannot find '$script'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/ptargrep.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/shasum.PL
===================================================================
--- trunk/contrib/perl/utils/shasum.PL (rev 0)
+++ trunk/contrib/perl/utils/shasum.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $script = File::Spec->catfile(
+ File::Spec->catdir(
+ File::Spec->updir, qw[cpan Digest-SHA]
+ ), "shasum");
+
+if (open(IN, '<', $script)) {
+ print OUT <IN>;
+ close IN;
+} else {
+ die "$0: cannot find '$script'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/shasum.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/splain.PL
===================================================================
--- trunk/contrib/perl/utils/splain.PL (rev 0)
+++ trunk/contrib/perl/utils/splain.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,56 @@
+#!/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:
+# $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 = File::Spec->catfile(File::Spec->updir, 'lib', 'diagnostics.pm');
+open IN, '<', $in or die "Can't open $in: $!\n";
+
+# Create output file.
+open OUT, '>', $file or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+print OUT <<'!NO!SUBS!';
+
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
+!NO!SUBS!
+
+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;
Property changes on: trunk/contrib/perl/utils/splain.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/xsubpp.PL
===================================================================
--- trunk/contrib/perl/utils/xsubpp.PL (rev 0)
+++ trunk/contrib/perl/utils/xsubpp.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $xsubpp = File::Spec->catfile(File::Spec->catdir(File::Spec->updir,
+ qw(dist ExtUtils-ParseXS
+ lib ExtUtils)),
+ 'xsubpp');
+
+if (open(XSUBPP, '<', $xsubpp)) {
+ print OUT <XSUBPP>;
+ close XSUBPP;
+} else {
+ die "$0: cannot find '$xsubpp'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/xsubpp.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
Added: trunk/contrib/perl/utils/zipdetails.PL
===================================================================
--- trunk/contrib/perl/utils/zipdetails.PL (rev 0)
+++ trunk/contrib/perl/utils/zipdetails.PL 2017-10-01 18:34:39 UTC (rev 9594)
@@ -0,0 +1,51 @@
+#!/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!
+
+use File::Spec;
+
+my $script = File::Spec->catfile(
+ File::Spec->catdir(
+ File::Spec->updir, qw[ cpan IO-Compress bin ]
+ ), "zipdetails");
+
+if (open(IN, '<', $script)) {
+ print OUT <IN>;
+ close IN;
+} else {
+ die "$0: cannot find '$script'\n";
+}
+
+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;
Property changes on: trunk/contrib/perl/utils/zipdetails.PL
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+MidnightBSD=%H
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+text/plain
\ No newline at end of property
More information about the Midnightbsd-cvs
mailing list