perl-5.6.0 + local changes

5 files changed, 1465 insertions, 514 deletions

diff --git a/gnu/usr.bin/perl/utils/Makefile b/gnu/usr.bin/perl/utils/Makefile
index 2df16d8060f..944cbe8711b 100644
--- a/gnu/usr.bin/perl/utils/Makefile
+++ b/gnu/usr.bin/perl/utils/Makefile
@@ -5,14 +5,14 @@ REALPERL = ../perl
 # Files to be built with variable substitution after miniperl is
 # available.  Dependencies handled manually below (for now).
 
-pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL
-plextract  = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc
-plextractexe  = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe
+pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL dprofpp.PL
+plextract  = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc dprofpp
+plextractexe  = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe dprofpp.exe
 
 all: $(plextract) 
 
 compile: all
-	$(REALPERL) -I../lib perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog;
+	$(REALPERL) -I../lib perlcc -opt -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog;
 
 $(plextract):
 	$(PERL) -I../lib $@.PL
@@ -31,12 +31,15 @@ pl2pm:		pl2pm.PL ../config.sh
 
 splain:		splain.PL ../config.sh ../lib/diagnostics.pm
 
-perlcc:     perlcc.PL ../config.sh
+perlcc:		perlcc.PL ../config.sh
+
+dprofpp:	dprofpp.PL ../config.sh
 
 clean:
 
 realclean:
 	rm -rf $(plextract) pstruct $(plextractexe)
+	rm -f ../t/_h2ph_pre.ph
 
 clobber:	realclean
 
diff --git a/gnu/usr.bin/perl/utils/h2ph.PL b/gnu/usr.bin/perl/utils/h2ph.PL
index 6011d98f1f1..0b0208b0ca4 100644
--- a/gnu/usr.bin/perl/utils/h2ph.PL
+++ b/gnu/usr.bin/perl/utils/h2ph.PL
@@ -528,7 +528,7 @@ sub inc_dirs
 sub build_preamble_if_necessary
 {
     # Increment $VERSION every time this function is modified:
-    my $VERSION     = 1;
+    my $VERSION     = 2;
     my $preamble    = "$Dest_dir/_h2ph_pre.ph";
 
     # Can we skip building the preamble file?
@@ -556,6 +556,9 @@ sub build_preamble_if_necessary
             if ($define{$_} =~ /^\d+$/) {
                 print PREAMBLE
                     "unless (defined &$_) { sub $_() { $define{$_} } }\n\n";
+            } elsif ($define{$_} =~ /^\w+$/) {
+                print PREAMBLE
+                    "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
             } else {
                 print PREAMBLE
                     "unless (defined &$_) { sub $_() { \"",
@@ -576,8 +579,7 @@ sub _extract_cc_defines
 
     # Split compiler pre-definitions into `key=value' pairs:
     foreach (split /\s+/, $allsymbols) {
-        /(.*?)=(.*)/;
-        $define{$1} = $2;
+        /(.+?)=(.+)/ and $define{$1} = $2;
 
         if ($opt_D) {
             print STDERR "$_:  $1 -> $2\n";
diff --git a/gnu/usr.bin/perl/utils/h2xs.PL b/gnu/usr.bin/perl/utils/h2xs.PL
index 129b01b81bf..ca0e7cbc324 100644
--- a/gnu/usr.bin/perl/utils/h2xs.PL
+++ b/gnu/usr.bin/perl/utils/h2xs.PL
@@ -41,7 +41,7 @@ h2xs - convert .h C header files to Perl extensions
 
 =head1 SYNOPSIS
 
-B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]]
+B<h2xs> [B<-ACOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]]
 
 B<h2xs> B<-h>
 
@@ -71,12 +71,21 @@ in the extra-libraries argument.
 =item B<-A>
 
 Omit all autoload facilities.  This is the same as B<-c> but also removes the
-S<C<require AutoLoader>> statement from the .pm file.
+S<C<use AutoLoader>> statement from the .pm file.
+
+=item B<-C>
+
+Omits creation of the F<Changes> file, and adds a HISTORY section to
+the POD template.
 
 =item B<-F>
 
 Additional flags to specify to C preprocessor when scanning header for
-function declarations. Should not be used without B<-x>.
+function declarations.  Should not be used without B<-x>.
+
+=item B<-M> I<regular expression>
+
+selects functions/macros to process.
 
 =item B<-O>
 
@@ -89,7 +98,21 @@ Omit the autogenerated stub POD section.
 =item B<-X>
 
 Omit the XS portion.  Used to generate templates for a module which is not
-XS-based.
+XS-based.  C<-c> and C<-f> are implicitly enabled.
+
+=item B<-a>
+
+Generate an accessor method for each element of structs and unions. The
+generated methods are named after the element name; will return the current
+value of the element if called without additional arguments; and will set
+the element to the supplied value (and return the new value) if called with
+an additional argument. Embedded structures and unions are returned as a
+pointer rather than the complete structure, to facilitate chained calls.
+
+These methods all apply to the Ptr type for the structure; additionally
+two methods are constructed for the structure type itself, C<_to_ptr>
+which returns a Ptr type pointing to the same structure, and a C<new>
+method to construct and return a new structure, initialised to zeroes.
 
 =item B<-c>
 
@@ -103,21 +126,46 @@ Turn on debugging messages.
 =item B<-f>
 
 Allows an extension to be created for a header even if that header is
-not found in /usr/include.
+not found in standard include directories.
 
 =item B<-h>
 
 Print the usage, help and version for this h2xs and exit.
 
+=item B<-k>
+
+For function arguments declared as C<const>, omit the const attribute in the
+generated XS code.
+
+=item B<-m>
+
+B<Experimental>: for each variable declared in the header file(s), declare
+a perl variable of the same name magically tied to the C variable.
+
 =item B<-n> I<module_name>
 
 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
 
+=item B<-o> I<regular expression>
+
+Use "opaque" data type for the C types matched by the regular
+expression, even if these types are C<typedef>-equivalent to types
+from typemaps.  Should not be used without B<-x>.
+
+This may be useful since, say, types which are C<typedef>-equivalent
+to integers may represent OS-related handles, and one may want to work
+with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
+Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types.
+
+The type-to-match is whitewashed (except for commas, which have no
+whitespace before them, and multiple C<*> which have no whitespace
+between them).
+
 =item B<-p> I<prefix>
 
 Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_> 
 This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
-autoloaded via the C<constant()> mechansim.
+autoloaded via the C<constant()> mechanism.
 
 =item B<-s> I<sub1,sub2>
 
@@ -140,7 +188,8 @@ 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.
+pointer (like C<long long>), pointers to functions, or arrays.  See
+also the section on L<LIMITATIONS of B<-x>>.
 
 =back
 
@@ -193,6 +242,12 @@ pointer (like C<long long>), pointers to functions, or arrays.
 	# 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
+
 =head1 ENVIRONMENT
 
 No environment variables are used.
@@ -209,27 +264,97 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
 
 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
 
-my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/;
+use strict;
+
+
+my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
 my $TEMPLATE_VERSION = '0.01';
+my @ARGS = @ARGV;
 
 use Getopt::Std;
 
 sub usage{
 	warn "@_\n" if @_;
-    die "h2xs [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
+    die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
 version: $H2XS_VERSION
     -A   Omit all autoloading facilities (implies -c).
+    -C   Omit creating the Changes file, add HISTORY heading to stub POD.
     -F   Additional flags for C preprocessor (used with -x).
+    -M   Mask to select C functions/macros (default is select all).
     -O   Allow overwriting of a pre-existing extension directory.
     -P   Omit the stub POD section.
-    -X   Omit the XS portion.
+    -X   Omit the XS portion (implies both -c and -f).
+    -a   Generate get/set accessors for struct and union members (used with -x).
     -c   Omit the constant() function and specialised AUTOLOAD from the XS file.
     -d   Turn on debugging messages.
     -f   Force creation of the extension even if the C header does not exist.
     -h   Display this help message
+    -k   Omit 'const' attribute on function arguments (used with -x).
+    -m   Generate tied variables for access to declared variables.
     -n   Specify a name to use for the extension (recommended).
+    -o   Regular expression for \"opaque\" types.
     -p   Specify a prefix which should be removed from the Perl function names.
     -s   Create subroutines for specified macros.
     -v   Specify a version number for this extension.
@@ -241,15 +366,25 @@ extra_libraries
 }
 
 
-getopts("AF:OPXcdfhn:p:s:v:x") || usage;
+getopts("ACF:M:OPXacdfhkmn:o:p:s:v:x") || usage;
+use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d
+	    $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x);
 
 usage if $opt_h;
 
 if( $opt_v ){
 	$TEMPLATE_VERSION = $opt_v;
 }
+
+# -A implies -c.
 $opt_c = 1 if $opt_A;
-%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+
+# -X implies -c and -f
+$opt_c = $opt_f = 1 if $opt_X;
+
+my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+my $extralibs;
+my @path_h;
 
 while (my $arg = shift) {
     if ($arg =~ /^-l/i) {
@@ -262,34 +397,78 @@ while (my $arg = shift) {
 usage "Must supply header file or module name\n"
         unless (@path_h or $opt_n);
 
+my $fmask;
+my $tmask;
+
+$fmask = qr{$opt_M} if defined $opt_M;
+$tmask = qr{$opt_o} if defined $opt_o;
+my $tmask_all = $tmask && $opt_o eq '.';
+
+if ($opt_x) {
+  eval {require C::Scan; 1}
+    or die <<EOD;
+C::Scan required if you use -x option.
+To install C::Scan, execute
+   perl -MCPAN -e "install C::Scan"
+EOD
+  unless ($tmask_all) {
+    $C::Scan::VERSION >= 0.70
+      or die <<EOD;
+C::Scan v. 0.70 or later required unless you use -o . option.
+You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
+To install C::Scan, execute
+   perl -MCPAN -e "install C::Scan"
+EOD
+  }
+  if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
+    die <<EOD;
+C::Scan v. 0.73 or later required to use -m or -a options.
+You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
+To install C::Scan, execute
+   perl -MCPAN -e "install C::Scan"
+EOD
+  }
+}
+elsif ($opt_o or $opt_F) {
+  warn <<EOD;
+Options -o and -F do not make sense without -x.
+EOD
+}
+
+my @path_h_ini = @path_h;
+my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
 
 if( @path_h ){
+    use Config;
+    use File::Spec;
+    my @paths;
+    if ($^O eq 'VMS') {  # Consider overrides of default location
+      # XXXX This is not equivalent to what the older version did:
+      #		it was looking at $hadsys header-file per header-file...
+      my($hadsys) = grep s!^sys/!!i , @path_h;
+      @paths = qw( Sys$Library VAXC$Include );
+      push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
+      push @paths, qw( DECC$Library_Include DECC$System_Include );
+    }
+    else {
+      @paths = (File::Spec->curdir(), $Config{usrinc},
+		(split ' ', $Config{locincpth}), '/usr/include');
+    }
     foreach my $path_h (@path_h) {
         $name ||= $path_h;
     if( $path_h =~ s#::#/#g && $opt_n ){
 	warn "Nesting of headerfile ignored with -n\n";
     }
     $path_h .= ".h" unless $path_h =~ /\.h$/;
-    $fullpath = $path_h;
+    my $fullpath = $path_h;
     $path_h =~ s/,.*$// if $opt_x;
-    if ($^O eq 'VMS') {  # Consider overrides of default location
-	if ($path_h !~ m![:>\[]!) {
-	    my($hadsys) = ($path_h =~ s!^sys/!!i);
-	    if ($ENV{'DECC$System_Include'})     { $path_h = "DECC\$System_Include:$path_h";    }
-	    elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h";   }
-	    elsif ($ENV{'GNU_CC_Include'})       { $path_h = 'GNU_CC_Include:' .
-	                                            ($hadsys ? '[vms]' : '[000000]') . $path_h; }
-	    elsif ($ENV{'VAXC$Include'})         { $path_h = "VAXC\$_Include:$path_h";          }
-	    else                                 { $path_h = "Sys\$Library:$path_h";            }
-	}
-    }
-    elsif ($^O eq 'os2') {
-	$path_h = "/usr/include/$path_h" 
-	  if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h"; 
-    }
-    else { 
-      $path_h = "/usr/include/$path_h" 
-	if $path_h !~ m#^[./]# and -r "/usr/include/$path_h"; 
+    $fullpath{$path_h} = $fullpath;
+
+    if (not -f $path_h) {
+      my $tmp_path_h = $path_h;
+      for my $dir (@paths) {
+	last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
+      }
     }
 
     if (!$opt_c) {
@@ -298,10 +477,24 @@ if( @path_h ){
       # Record the names of simple #define constants into const_names
             # Function prototypes are processed below.
       open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
+    defines:
       while (<CH>) {
-	if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) {
-	    print "Matched $_ ($1)\n" if $opt_d;
-	    $_ = $1;
+	if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
+	    my $def = $1;
+	    my $rest = $2;
+	    $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
+	    $rest =~ s/^\s+//;
+	    $rest =~ s/\s+$//;
+	    # Cannot do: (-1) and ((LHANDLE)3) are OK:
+	    #print("Skip non-wordy $def => $rest\n"),
+	    #  next defines if $rest =~ /[^\w\$]/;
+	    if ($rest =~ /"/) {
+	      print("Skip stringy $def => $rest\n") if $opt_d;
+	      next defines;
+	    }
+	    print "Matched $_ ($def)\n" if $opt_d;
+	    $seen_define{$def} = $rest;
+	    $_ = $def;
 	    next if /^_.*_h_*$/i; # special case, but for what?
 	    if (defined $opt_p) {
 	      if (!/^$opt_p(\d)/) {
@@ -311,17 +504,20 @@ if( @path_h ){
 		warn "can't remove $opt_p prefix from '$_'!\n";
 	      }
 	    }
-	    $const_names{$_}++;
+	    $prefixless{$def} = $_;
+	    if (!$fmask or /$fmask/) {
+		print "... Passes mask of -M.\n" if $opt_d and $fmask;
+		$const_names{$_}++;
+	    }
 	  }
       }
       close(CH);
     }
     }
-    @const_names = sort keys %const_names;
 }
 
 
-$module = $opt_n || do {
+my $module = $opt_n || do {
 	$name =~ s/\.h$//;
 	if( $name !~ /::/ ){
 		$name =~ s#^.*/##;
@@ -330,6 +526,7 @@ $module = $opt_n || do {
 	$name;
 };
 
+my ($ext, $nested, @modparts, $modfname, $modpname);
 (chdir 'ext', $ext = 'ext/') if -d 'ext';
 
 if( $module =~ /::/ ){
@@ -347,11 +544,12 @@ else {
 
 if ($opt_O) {
 	warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
-} else {
+}
+else {
 	die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 }
 if( $nested ){
-	$modpath = "";
+	my $modpath = "";
 	foreach (@modparts){
 		mkdir("$modpath$_", 0777);
 		$modpath .= "$_/";
@@ -362,36 +560,125 @@ chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 
 my %types_seen;
 my %std_types;
-my $fdecls;
-my $fdecls_parsed;
+my $fdecls = [];
+my $fdecls_parsed = [];
+my $typedef_rex;
+my %typedefs_pre;
+my %known_fnames;
+my %structs;
+
+my @fnames;
+my @fnames_no_prefix;
+my %vdecl_hash;
+my @vdecls;
 
 if( ! $opt_X ){  # use XS, unless it was disabled
   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
   if ($opt_x) {
-    require C::Scan;		# Run-time directive
     require Config;		# Run-time directive
     warn "Scanning typemaps...\n";
     get_typemap();
-    my $c;
-    my $filter;
-        my @fdecls;
-        foreach my $filename (@path_h) {
+    my @td;
+    my @good_td;
     my $addflags = $opt_F || '';
-    if ($fullpath =~ /,/) {
-      $filename = $`;
-      $filter = $';
+
+    foreach my $filename (@path_h) {
+      my $c;
+      my $filter;
+
+      if ($fullpath{$filename} =~ /,/) {
+	$filename = $`;
+	$filter = $';
+      }
+      warn "Scanning $filename for functions...\n";
+      $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
+	'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)];
+      $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
+
+      push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
+      push(@$fdecls, @{$c->get('fdecls')});
+
+      push @td, @{$c->get('typedefs_maybe')};
+      if ($opt_a) {
+	my $structs = $c->get('typedef_structs');
+	@structs{keys %$structs} = values %$structs;
+      }
+
+      if ($opt_m) {
+	%vdecl_hash = %{ $c->get('vdecl_hash') };
+	@vdecls = sort keys %vdecl_hash;
+	for (local $_ = 0; $_ < @vdecls; ++$_) {
+	  my $var = $vdecls[$_];
+	  my($type, $post) = @{ $vdecl_hash{$var} };
+	  if (defined $post) {
+	    warn "Can't handle variable '$type $var $post', skipping.\n";
+	    splice @vdecls, $_, 1;
+	    redo;
+	  }
+	  $type = normalize_type($type);
+	  $vdecl_hash{$var} = $type;
+	}
+      }
+
+      unless ($tmask_all) {
+	warn "Scanning $filename for typedefs...\n";
+	my $td = $c->get('typedef_hash');
+	# eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
+	my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
+	push @good_td, @f_good_td;
+	@typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
+      }
+    }
+    { local $" = '|';
+      $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
+    }
+    %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
+    if ($fmask) {
+      my @good;
+      for my $i (0..$#$fdecls_parsed) {
+	next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
+	push @good, $i;
+	print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
+	  if $opt_d;
+      }
+      $fdecls = [@$fdecls[@good]];
+      $fdecls_parsed = [@$fdecls_parsed[@good]];
+    }
+    @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
+    # Sort declarations:
+    {
+      my %h = map( ($_->[1], $_), @$fdecls_parsed);
+      $fdecls_parsed = [ @h{@fnames} ];
+    }
+    @fnames_no_prefix = @fnames;
+    @fnames_no_prefix
+      = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
+    # Remove macros which expand to typedefs
+    print "Typedefs are @td.\n" if $opt_d;
+    my %td = map {($_, $_)} @td;
+    # Add some other possible but meaningless values for macros
+    for my $k (qw(char double float int long short unsigned signed void)) {
+      $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
+    }
+    # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
+    my $n = 0;
+    my %bad_macs;
+    while (keys %td > $n) {
+      $n = keys %td;
+      my ($k, $v);
+      while (($k, $v) = each %seen_define) {
+	# print("found '$k'=>'$v'\n"), 
+	$bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
+      }
+    }
+    # Now %bad_macs contains names of bad macros
+    for my $k (keys %bad_macs) {
+      delete $const_names{$prefixless{$k}};
+      print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
     }
-    warn "Scanning $filename for functions...\n";
-    $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
-    'add_cppflags' => $addflags;
-    $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
-    
-    $fdecls_parsed = $c->get('parsed_fdecls');
-            push(@fdecls, @{$c->get('fdecls')});
-        }
-        $fdecls = [ @fdecls ];
   }
 }
+my @const_names = sort keys %const_names;
 
 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 
@@ -401,21 +688,16 @@ warn "Writing $ext$modpname/$modfname.pm\n";
 print PM <<"END";
 package $module;
 
+require 5.005_62;
 use strict;
+use warnings;
 END
 
-if( $opt_X || $opt_c || $opt_A ){
-	# we won't have our own AUTOLOAD(), so won't have $AUTOLOAD
-	print PM <<'END';
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-END
-}
-else{
+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;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
 END
 }
 
@@ -428,58 +710,50 @@ print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
 require DynaLoader;
 END
 
-# require autoloader if XS is disabled.
-# if XS is enabled, require autoloader unless autoloading is disabled.
-if( ($opt_X && (! $opt_A)) || (!$opt_X) ) {
-	print PM <<"END";
-require AutoLoader;
-END
-}
-
-if( $opt_X || ($opt_c && ! $opt_A) ){
-	# we won't have our own AUTOLOAD(), so we'll inherit it.
-	if( ! $opt_X ) { # use DynaLoader, unless XS was disabled
-		print PM <<"END";
 
-\@ISA = qw(Exporter AutoLoader DynaLoader);
-END
+# Are we using AutoLoader or not?
+unless ($opt_A) { # no autoloader whatsoever.
+	unless ($opt_c) { # we're doing the AUTOLOAD
+		print PM "use AutoLoader;\n";
 	}
-	else{
-		print PM <<"END";
-
-\@ISA = qw(Exporter AutoLoader);
-END
+	else {
+		print PM "use AutoLoader qw(AUTOLOAD);\n"
 	}
 }
-else{
-	# 1) we have our own AUTOLOAD(), so don't need to inherit it.
-	# or
-	# 2) we don't want autoloading mentioned.
-	if( ! $opt_X ){ # use DynaLoader, unless XS was disabled
-		print PM <<"END";
 
-\@ISA = qw(Exporter DynaLoader);
-END
-	}
-	else{
-		print PM <<"END";
+# Determine @ISA.
+my $myISA = 'our @ISA = qw(Exporter';	# We seem to always want this.
+$myISA .= ' DynaLoader' 	unless $opt_X;  # no XS
+$myISA .= ');';
+print PM "\n$myISA\n\n";
 
-\@ISA = qw(Exporter);
-END
-	}
-}
+my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
 
 print PM<<"END";
 # Items to export into callers namespace by default. Note: do not export
 # names by default without a very good reason. Use EXPORT_OK instead.
 # Do not simply export all your public functions/methods/constants.
-\@EXPORT = qw(
+
+# 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
 );
-\$VERSION = '$TEMPLATE_VERSION';
+our \$VERSION = '$TEMPLATE_VERSION';
 
 END
 
+if (@vdecls) {
+    printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
+}
+
 print PM <<"END" unless $opt_c or $opt_X;
 sub AUTOLOAD {
     # This AUTOLOAD is used to 'autoload' constants from the constant()
@@ -487,20 +761,29 @@ sub AUTOLOAD {
     # to the AUTOLOAD in AutoLoader.
 
     my \$constname;
+    our \$AUTOLOAD;
     (\$constname = \$AUTOLOAD) =~ s/.*:://;
     croak "&$module::constant not defined" if \$constname eq 'constant';
     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
     if (\$! != 0) {
-	if (\$! =~ /Invalid/) {
+	if (\$! =~ /Invalid/ || \$!{EINVAL}) {
 	    \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 	    goto &AutoLoader::AUTOLOAD;
 	}
 	else {
-		croak "Your vendor has not defined $module macro \$constname";
+	    croak "Your vendor has not defined $module macro \$constname";
+	}
+    }
+    {
+	no strict 'refs';
+	# Fixed between 5.005_53 and 5.005_61
+	if (\$] >= 5.00561) {
+	    *\$AUTOLOAD = sub () { \$val };
+	}
+	else {
+	    *\$AUTOLOAD = sub { \$val };
 	}
     }
-    no strict 'refs';
-    *\$AUTOLOAD = sub () { \$val };
     goto &\$AUTOLOAD;
 }
 
@@ -512,6 +795,17 @@ bootstrap $module \$VERSION;
 END
 }
 
+# tying the variables can happen only after bootstrap
+if (@vdecls) {
+    printf PM <<END;
+{
+@{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
+}
+
+END
+}
+
+my $after;
 if( $opt_P ){ # if POD is disabled
 	$after = '__END__';
 }
@@ -522,37 +816,71 @@ else {
 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
 
-$author = "A. U. Thor";
-$email = 'a.u.thor@a.galaxy.far.far.away';
+my $author = "A. U. Thor";
+my $email = 'a.u.thor@a.galaxy.far.far.away';
+
+my $revhist = '';
+$revhist = <<EOT if $opt_C;
+
+=head1 HISTORY
 
-my $const_doc = '';
-my $fdecl_doc = '';
+=over 8
+
+=item $TEMPLATE_VERSION
+
+Original version; created by h2xs $H2XS_VERSION with options
+
+  @ARGS
+
+=back
+
+EOT
+
+my $exp_doc = <<EOD;
+
+=head2 EXPORT
+
+None by default.
+
+EOD
 if (@const_names and not $opt_P) {
-  $const_doc = <<EOD;
-\n=head1 Exported constants
+  $exp_doc .= <<EOD;
+=head2 Exportable constants
 
   @{[join "\n  ", @const_names]}
 
 EOD
 }
 if (defined $fdecls and @$fdecls and not $opt_P) {
-  $fdecl_doc = <<EOD;
-\n=head1 Exported functions
+  $exp_doc .= <<EOD;
+=head2 Exportable functions
+
+EOD
+  $exp_doc .= <<EOD if $opt_p;
+When accessing these functions from Perl, prefix C<$opt_p> should be removed.
 
-  @{[join "\n  ", @$fdecls]}
+EOD
+  $exp_doc .= <<EOD;
+  @{[join "\n  ", @known_fnames{@fnames}]}
 
 EOD
 }
 
-$pod = <<"END" unless $opt_P;
-## Below is the stub of documentation for your module. You better edit it!
+my $pod = <<"END" unless $opt_P;
+## Below is stub documentation for your module. You better edit it!
 #
 #=head1 NAME
 #
@@ -565,12 +893,12 @@ $pod = <<"END" unless $opt_P;
 #
 #=head1 DESCRIPTION
 #
-#Stub documentation for $module was created by h2xs. It looks like the
+#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.
-#$const_doc$fdecl_doc
+#$exp_doc$revhist
 #=head1 AUTHOR
 #
 #$author, $email
@@ -598,7 +926,7 @@ print XS <<"END";
 
 END
 if( @path_h ){
-    foreach my $path_h (@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#.*[:>\]]##; }
@@ -607,54 +935,185 @@ if( @path_h ){
     print XS "\n";
 }
 
-if( ! $opt_c ){
-print XS <<"END";
-static int
-not_here(char *s)
+my %pointer_typedefs;
+my %struct_typedefs;
+
+sub td_is_pointer {
+  my $type = shift;
+  my $out = $pointer_typedefs{$type};
+  return $out if defined $out;
+  my $otype = $type;
+  $out = ($type =~ /\*$/);
+  # This converts only the guys which do not have trailing part in the typedef
+  if (not $out
+      and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+    $type = normalize_type($type);
+    print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
+      if $opt_d;
+    $out = td_is_pointer($type);
+  }
+  return ($pointer_typedefs{$otype} = $out);
+}
+
+sub td_is_struct {
+  my $type = shift;
+  my $out = $struct_typedefs{$type};
+  return $out if defined $out;
+  my $otype = $type;
+  $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
+  # This converts only the guys which do not have trailing part in the typedef
+  if (not $out
+      and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+    $type = normalize_type($type);
+    print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
+      if $opt_d;
+    $out = td_is_struct($type);
+  }
+  return ($struct_typedefs{$otype} = $out);
+}
+
+# Some macros will bomb if you try to return them from a double-returning func.
+# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
+# Fortunately, we can detect both these cases...
+sub protect_convert_to_double {
+  my $in = shift;
+  my $val;
+  return '' unless defined ($val = $seen_define{$in});
+  return '(IV)' if $known_fnames{$val};
+  # OUT_t of ((OUT_t)-1):
+  return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
+  td_is_pointer($2) ? '(IV)' : '';
+}
+
+# For each of the generated functions, length($pref) leading
+# letters are already checked.  Moreover, it is recommended that
+# the generated functions uses switch on letter at offset at least
+# $off + length($pref).
+#
+# The given list has length($pref) chars removed at front, it is
+# guarantied that $off leading chars in the rest are the same for all
+# elts of the list.
+#
+# Returns: how at which offset it was decided to make a switch, or -1 if none.
+
+sub write_const;
+
+sub write_const {
+  my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
+  my %leading;
+  my $offarg = length $pref;
+
+  if (@$list == 0) {		# Can happen on the initial iteration only
+    print $fh <<"END";
+static double
+constant(char *name, int len, int arg)
 {
-    croak("$module::%s not implemented on this architecture", s);
-    return -1;
+    errno = EINVAL;
+    return 0;
 }
+END
+    return -1;
+  }
 
+  if (@$list == 1) {		# Can happen on the initial iteration only
+    my $protect = protect_convert_to_double("$pref$list->[0]");
+
+    print $fh <<"END";
 static double
-constant(char *name, int arg)
+constant(char *name, int len, int arg)
 {
     errno = 0;
-    switch (*name) {
+    if (strEQ(name + $offarg, "$list->[0]")) {	/* $pref removed */
+#ifdef $pref$list->[0]
+	return $protect$pref$list->[0];
+#else
+	errno = ENOENT;
+	return 0;
+#endif
+    }
+    errno = EINVAL;
+    return 0;
+}
 END
+    return -1;
+  }
 
-my(@AZ, @az, @under);
+  for my $n (@$list) {
+    my $c = substr $n, $off, 1;
+    $leading{$c} = [] unless exists $leading{$c};
+    push @{$leading{$c}}, substr $n, $off + 1;
+  }
 
-foreach(@const_names){
-    @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
-    @az = 'a' .. 'z' if !@az && /^[a-z]/;
-    @under = '_'  if !@under && /^_/;
-}
+  if (keys(%leading) == 1) {
+    return 1 + write_const $fh, $pref, $off + 1, $list;
+  }
 
-foreach $letter (@AZ, @az, @under) {
+  my $leader = substr $list->[0], 0, $off;
+  foreach my $letter (keys %leading) {
+    write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
+      if @{$leading{$letter}} > 1;
+  }
 
-    last if $letter eq 'a' && !@const_names;
+  my $npref = "_$pref";
+  $npref = '' if $pref eq '';
 
-    print XS "    case '$letter':\n";
-    my($name);
-    while (substr($const_names[0],0,1) eq $letter) {
-	$name = shift(@const_names);
-	$macro = $prefix{$name} ? "$opt_p$name" : $name;
-	next if $const_xsub{$macro};
-	print XS <<"END";
-	if (strEQ(name, "$name"))
-#ifdef $macro
-	    return $macro;
+  print $fh <<"END";
+static double
+constant$npref(char *name, int len, int arg)
+{
+END
+
+  print $fh <<"END" if $npref eq '';
+    errno = 0;
+END
+
+  print $fh <<"END" if $off;
+    if ($offarg + $off >= len ) {
+	errno = EINVAL;
+	return 0;
+    }
+END
+
+  print $fh <<"END";
+    switch (name[$offarg + $off]) {
+END
+
+  foreach my $letter (sort keys %leading) {
+    my $let = $letter;
+    $let = '\0' if $letter eq '';
+
+    print $fh <<EOP;
+    case '$let':
+EOP
+    if (@{$leading{$letter}} > 1) {
+      # It makes sense to call a function
+      if ($off) {
+	print $fh <<EOP;
+	if (!strnEQ(name + $offarg,"$leader", $off))
+	    break;
+EOP
+      }
+      print $fh <<EOP;
+	return constant_$pref$leader$letter(name, len, arg);
+EOP
+    }
+    else {
+      # Do it ourselves
+      my $protect
+	= protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
+
+      print $fh <<EOP;
+	if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) {	/* $pref removed */
+#ifdef $pref$leader$letter$leading{$letter}[0]
+	    return $protect$pref$leader$letter$leading{$letter}[0];
 #else
 	    goto not_there;
 #endif
-END
+	}
+EOP
     }
-    print XS <<"END";
-	break;
-END
-}
-print XS <<"END";
+  }
+  print $fh <<"END";
     }
     errno = EINVAL;
     return 0;
@@ -665,9 +1124,28 @@ not_there:
 }
 
 END
+
+}
+
+if( ! $opt_c ) {
+  print XS <<"END";
+static int
+not_here(char *s)
+{
+    croak("$module::%s not implemented on this architecture", s);
+    return -1;
+}
+
+END
+
+  write_const(\*XS, '', 0, \@const_names);
 }
 
+print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
+
+my $prefix;
 $prefix = "PREFIX = $opt_p" if defined $opt_p;
+
 # Now switch from C to XS by issuing the first MODULE declaration:
 print XS <<"END";
 
@@ -682,13 +1160,13 @@ $_()
 
     CODE:
 #ifdef $_
-    RETVAL = $_;
+	RETVAL = $_;
 #else
-    croak("Your vendor has not defined the $module macro $_");
+	croak("Your vendor has not defined the $module macro $_");
 #endif
 
     OUTPUT:
-    RETVAL
+	RETVAL
 
 END
 }
@@ -698,14 +1176,22 @@ END
 print XS <<"END" unless $opt_c;
 
 double
-constant(name,arg)
-	char *		name
+constant(sv,arg)
+    PREINIT:
+	STRLEN		len;
+    INPUT:
+	SV *		sv
+	char *		s = SvPV(sv, len);
 	int		arg
+    CODE:
+	RETVAL = constant(s,len,arg);
+    OUTPUT:
+	RETVAL
 
 END
 
 my %seen_decl;
-
+my %typemap;
 
 sub print_decl {
   my $fh = shift;
@@ -714,7 +1200,10 @@ sub print_decl {
   return if $seen_decl{$name}++; # Need to do the same for docs as well?
 
   my @argnames = map {$_->[1]} @$args;
-  my @argtypes = map { normalize_type( $_->[0] ) } @$args;
+  my @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 '...') {
@@ -722,21 +1211,152 @@ sub print_decl {
     $argnames[-1] = '...';
   }
   local $" = ', ';
-  $type = normalize_type($type);
-  
+  $type = normalize_type($type, 1);
+
   print $fh <<"EOP";
 
 $type
 $name(@argnames)
 EOP
 
-  for $arg (0 .. $numargs - 1) {
+  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
+    }
+  }
+}
+
 # Should be called before any actual call to normalize_type().
 sub get_typemap {
   # We do not want to read ./typemap by obvios reasons.
@@ -744,9 +1364,11 @@ sub get_typemap {
   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
   unshift @tm, $stdtypemap;
   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
-  my $image;
-  
-  foreach $typemap (@tm) {
+
+  # Start with useful default values
+  $typemap{float} = 'T_DOUBLE';
+
+  foreach my $typemap (@tm) {
     next unless -e $typemap ;
     # skip directories, binary files etc.
     warn " Scanning $typemap\n";
@@ -762,11 +1384,12 @@ sub get_typemap {
       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
       elsif ($mode eq 'Typemap') {
 	next if /^\s*($|\#)/ ;
-	if ( ($type, $image) = 
+	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)) {
-	  normalize_type($type);
+	  $typemap{normalize_type($type)} = $image;
 	}
       }
     }
@@ -777,24 +1400,64 @@ sub get_typemap {
 }
 
 
-sub normalize_type {
-  my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
+sub normalize_type {		# Second arg: do not strip const's before \*
   my $type = shift;
-  $type =~ s/$ignore_mods//go;
-  $type =~ s/([\]\[()])/ \1 /g;
-  $type =~ s/\s+/ /g;
+  my $do_keep_deep_const = shift;
+  # If $do_keep_deep_const this is heuristical only
+  my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
+  my $ignore_mods 
+    = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
+  if ($do_keep_deep_const) {	# Keep different compiled /RExen/o separately!
+    $type =~ s/$ignore_mods//go;
+  }
+  else {
+    $type =~ s/$ignore_mods//go;
+  }
+  $type =~ s/([^\s\w])/ \1 /g;
   $type =~ s/\s+$//;
   $type =~ s/^\s+//;
-  $type =~ s/\b\*/ */g;
-  $type =~ s/\*\b/* /g;
-  $type =~ s/\*\s+(?=\*)/*/g;
+  $type =~ s/\s+/ /g;
+  $type =~ s/\* (?=\*)/*/g;
+  $type =~ s/\. \. \./.../g;
+  $type =~ s/ ,/,/g;
   $types_seen{$type}++ 
     unless $type eq '...' or $type eq 'void' or $std_types{$type};
   $type;
 }
 
+my $need_opaque;
+
+sub assign_typemap_entry {
+  my $type = shift;
+  my $otype = $type;
+  my $entry;
+  if ($tmask and $type =~ /$tmask/) {
+    print "Type $type matches -o mask\n" if $opt_d;
+    $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+  }
+  elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+    $type = normalize_type $type;
+    print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
+    $entry = assign_typemap_entry($type);
+  }
+  $entry ||= $typemap{$otype}
+    || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+  $typemap{$otype} = $entry;
+  $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
+  return $entry;
+}
+
+for (@vdecls) {
+  print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
+}
+
 if ($opt_x) {
-    for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
+  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;
@@ -804,10 +1467,32 @@ if (%types_seen) {
   warn "Writing $ext$modpname/typemap\n";
   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
 
-  for $type (keys %types_seen) {
-    print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n"
+  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: $!";
 }
 
@@ -816,18 +1501,22 @@ if (%types_seen) {
 warn "Writing $ext$modpname/Makefile.PL\n";
 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
 
-print PL <<'END';
+print PL <<END;
 use ExtUtils::MakeMaker;
 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
 # the contents of the Makefile that is written.
+WriteMakefile(
+    'NAME'		=> '$module',
+    'VERSION_FROM'	=> '$modfname.pm', # finds \$VERSION
+    'PREREQ_PM'		=> {}, # e.g., Module::Name => 1.1
+END
+if (!$opt_X) { # print C stuff, unless XS is disabled
+  $opt_F = '' unless defined $opt_F;
+  print PL <<END;
+    'LIBS'		=> ['$extralibs'], # e.g., '-lm'
+    'DEFINE'		=> '$opt_F', # e.g., '-DHAVE_SOMETHING'
+    'INC'		=> '', # e.g., '-I/usr/include/other'
 END
-print PL "WriteMakefile(\n";
-print PL "    'NAME'	=> '$module',\n";
-print PL "    'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n"; 
-if( ! $opt_X ){ # print C stuff, unless XS is disabled
-  print PL "    'LIBS'	=> ['$extralibs'],   # e.g., '-lm' \n";
-  print PL "    'DEFINE'	=> '',     # e.g., '-DHAVE_SOMETHING' \n";
-  print PL "    'INC'	=> '',     # e.g., '-I/usr/include/other' \n";
 }
 print PL ");\n";
 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
@@ -862,16 +1551,25 @@ print "ok 1\n";
 _END_
 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
 
-warn "Writing $ext$modpname/Changes\n";
-open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
-print EX "Revision history for Perl extension $module.\n\n";
-print EX "$TEMPLATE_VERSION  ",scalar localtime,"\n";
-print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
-close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
+unless ($opt_C) {
+  warn "Writing $ext$modpname/Changes\n";
+  $" = ' ';
+  open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
+  @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
+  print EX <<EOP;
+Revision history for Perl extension $module.
+
+$TEMPLATE_VERSION  @{[scalar localtime]}
+\t- original version; created by h2xs $H2XS_VERSION with options
+\t\t@ARGS
+
+EOP
+  close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
+}
 
 warn "Writing $ext$modpname/MANIFEST\n";
 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
-@files = <*>;
+my @files = <*>;
 if (!@files) {
   eval {opendir(D,'.');};
   unless ($@) { @files = readdir(D); closedir(D); }
diff --git a/gnu/usr.bin/perl/utils/perlbug.PL b/gnu/usr.bin/perl/utils/perlbug.PL
index 6f8758919f6..208da3667c4 100644
--- a/gnu/usr.bin/perl/utils/perlbug.PL
+++ b/gnu/usr.bin/perl/utils/perlbug.PL
@@ -3,6 +3,7 @@
 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
@@ -23,7 +24,8 @@ open OUT, ">$file" or die "Can't create $file: $!";
 
 # extract patchlevel.h information
 
-open PATCH_LEVEL, "<../patchlevel.h" or die "Can't open patchlevel.h: $!";
+open PATCH_LEVEL, "<" . catfile(updir, "patchlevel.h")
+    or die "Can't open patchlevel.h: $!";
 
 my $patchlevel_date = (stat PATCH_LEVEL)[9];
 
@@ -35,8 +37,8 @@ my @patches;
 while (<PATCH_LEVEL>) {
     last if /^\s*}/;
     chomp;
-    s/^\s+,?"?//;
-    s/"?,?$//;
+    s/^\s+,?\s*"?//;
+    s/"?\s*,?$//;
     s/(['\\])/\\$1/g;
     push @patches, $_ unless $_ eq 'NULL';
 }
@@ -55,12 +57,14 @@ print "Extracting $file (with variable substitutions)\n";
 # In this section, perl variables will be expanded during extraction.
 # You can use $Config{...} to use Configure variables.
 
+my $extract_version = sprintf("v%vd", $^V);
+
 print OUT <<"!GROK!THIS!";
 $Config{startperl}
     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
 	if \$running_under_some_shell;
 
-my \$config_tag1 = '$] - $Config{cf_time}';
+my \$config_tag1 = '$extract_version - $Config{cf_time}';
 
 my \$patchlevel_date = $patchlevel_date;
 my \$patch_tags = '$patch_tags';
@@ -74,6 +78,7 @@ my \@patches = (
 print OUT <<'!NO!SUBS!';
 
 use Config;
+use File::Spec;		# keep perlbug Perl 5.005 compatible
 use Getopt::Std;
 use strict;
 
@@ -86,7 +91,7 @@ BEGIN {
     $::HaveUtil = ($@ eq "");
 };
 
-my $Version = "1.26";
+my $Version = "1.28";
 
 # Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
 # Changed in 1.07 to see more sendmail execs, and added pipe output.
@@ -117,6 +122,8 @@ my $Version = "1.26";
 # Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
 # Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
 # Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
+# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
+# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
 
 # TODO: - Allow the user to re-name the file on mail failure, and
 #       make sure failure (transmission-wise) of Mail::Send is
@@ -124,10 +131,12 @@ my $Version = "1.26";
 #       - Test -b option
 
 my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename,
-    $subject, $from, $verbose, $ed, $outfile,
+    $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity, 
     $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok);
 
-my $config_tag2 = "$] - $Config{cf_time}";
+my $perl_version = $^V ? sprintf("v%vd", $^V) : $];
+
+my $config_tag2 = "$perl_version - $Config{cf_time}";
 
 Init();
 
@@ -149,11 +158,43 @@ Send();
 
 exit;
 
+sub ask_for_alternatives {
+    my $name = shift;
+    my $default = shift;
+    my @alts = @_;
+    my $alt = "";
+    paraprint <<EOF;
+Please pick a \u$name from the following:
+
+    @alts
+
+EOF
+    my $err = 0;
+    my $joined_alts = join('|', @alts);
+    do {
+	if ($err++ > 5) {
+	    die "Invalid $name: aborting.\n";
+	}
+	print "Please enter a \u$name [$default]: ";
+	$alt = <>;
+	chomp $alt;
+	if ($alt =~ /^\s*$/) {
+	    $alt = $default;
+	}
+    } while ($alt !~ /^($joined_alts)$/i);
+    lc $alt;
+}
+
 sub Init {
     # -------- Setup --------
 
     $Is_MSWin32 = $^O eq 'MSWin32';
     $Is_VMS = $^O eq 'VMS';
+    $Is_MacOS = $^O eq 'MacOS';
+
+    @ARGV = split m/\s+/,
+        MacPerl::Ask('Provide command-line args here (-h for help):')
+        if $Is_MacOS && $MacPerl::Version =~ /App/;
 
     if (!getopts("dhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; };
 
@@ -196,6 +237,7 @@ sub Init {
     $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
 	|| ($Is_VMS && "edit/tpu")
 	|| ($Is_MSWin32 && "notepad")
+	|| ($Is_MacOS && '')
 	|| "vi";
 
     # Not OK - provide build failure template by finessing OK report
@@ -232,8 +274,10 @@ EOF
 	    $::opt_C = 1; # don't send a copy to the local admin
 	    $::opt_s = 1; # we have a subject line
 	    $subject = ($::opt_n ? 'Not ' : '')
-		    . "OK: perl $] ${patch_tags}on"
+		    . "OK: perl $perl_version ${patch_tags}on"
 		    ." $::Config{'archname'} $::Config{'osvers'} $subject";
+	    $category = "install";
+	    $severity = "none";
 	    $ok = 1;
 	} else {
 	    Help();
@@ -255,6 +299,7 @@ EOF
     # My username
     $me = $Is_MSWin32 ? $ENV{'USERNAME'}
 	    : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
+	    : $Is_MacOS ? $ENV{'USER'}
 	    : eval { getpwuid($<) };	# May be missing
 
     $from = $::Config{'cf_email'}
@@ -307,6 +352,13 @@ EOF
 	my $guess;
 
 	$guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
+        if ($Is_MacOS) {
+            require Mac::InternetConfig;
+            $guess = $Mac::InternetConfig::InternetConfig{
+                Mac::InternetConfig::kICEmail()
+            };
+        }
+
 	unless ($guess) {
 	    my $domain;
 	    if ($::HaveUtil) {
@@ -415,6 +467,16 @@ EOF
 	}
     }
 
+    # Prompt for category of bug
+    $category ||= ask_for_alternatives("category", "core",
+				     qw(core docs install
+					library utilities));
+
+    # Prompt for severity of bug
+    $severity ||= ask_for_alternatives("severity", "low",
+				       qw(critical high medium
+					  low wishlist none));
+
     # Generate scratch file to edit report in
     $filename = filename();
 
@@ -452,7 +514,7 @@ EOF
 
     print REP <<EOF;
 This is a $reptype report for perl from $from,
-generated with the help of perlbug $Version running under perl $].
+generated with the help of perlbug $Version running under perl $perl_version.
 
 EOF
 
@@ -494,13 +556,19 @@ EOF
 sub Dump {
     local(*OUT) = @_;
 
-    print REP "\n---\n";
-    print REP "This perlbug was built using Perl $config_tag1\n",
+    print OUT <<EFF;
+---
+Flags:
+    category=$category
+    severity=$severity
+---
+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 $]:
+Site configuration information for perl $perl_version:
 
 EOF
     if ($::Config{cf_by} and $::Config{cf_time}) {
@@ -516,7 +584,7 @@ EOF
     print OUT <<EOF;
 
 ---
-\@INC for perl $]:
+\@INC for perl $perl_version:
 EOF
     for my $i (@INC) {
 	print OUT "    $i\n";
@@ -525,18 +593,21 @@ EOF
     print OUT <<EOF;
 
 ---
-Environment for perl $]:
+Environment for perl $perl_version:
 EOF
-    for my $env (sort
-	(qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE),
-	grep /^(?:PERL|LC_)/, keys %ENV)
-    ) {
+    my @env =
+        qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
+    push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
+    push @env, grep /^(?:PERL|LC_|LANG)/, keys %ENV;
+    my %env;
+    @env{@env} = @env;
+    for my $env (sort keys %env) {
 	print OUT "    $env",
 		exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
 		"\n";
     }
     if ($verbose) {
-	print OUT "\nComplete configuration data for perl $]:\n\n";
+	print OUT "\nComplete configuration data for perl $perl_version:\n\n";
 	my $value;
 	foreach (sort keys %::Config) {
 	    $value = $::Config{$_};
@@ -559,7 +630,15 @@ EOF
     }
 
 tryagain:
-    my $sts = system("$ed $filename");
+    my $sts = system("$ed $filename") unless $Is_MacOS;
+    if ($Is_MacOS) {
+        require ExtUtils::MakeMaker;
+        ExtUtils::MM_MacOS::launch_file($filename);
+        paraprint <<EOF;
+Press Enter when done.
+EOF
+        scalar <>;
+    }
     if ($sts) {
 	paraprint <<EOF;
 The editor you chose (`$ed') could apparently not be run!
@@ -783,7 +862,7 @@ Options:
   -v    Include Verbose configuration data in the report
   -f    File containing the body of the report. Use this to
         quickly send a prepared message.
-  -F	File to output the resulting mail message to, instead of mailing.
+  -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'.
@@ -796,7 +875,7 @@ Options:
         this if you don't give it here.
   -e    Editor to use.
   -t    Test mode. The target address defaults to `$testaddress'.
-  -d	Data mode (the default if you redirect or pipe output.)
+  -d    Data mode (the default if you redirect or pipe output.)
         This prints out your configuration data, without mailing
         anything. You can use this with -v to get more complete data.
   -ok   Report successful build on this system to perl porters
@@ -815,11 +894,12 @@ EOF
 sub filename {
     my $dir = $Is_VMS ? 'sys$scratch:'
 	: ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'}
-	: '/tmp/';
+        : $Is_MacOS ? $ENV{'TMPDIR'}
+	: '/tmp';
     $filename = "bugrep0$$";
-    $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|;
-    $filename++ while -e "$dir$filename";
-    $filename = "$dir$filename";
+#    $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|;
+    $filename++ while -e File::Spec->catfile($dir, $filename);
+    $filename = File::Spec->catfile($dir, $filename);
 }
 
 sub paraprint {
@@ -878,7 +958,7 @@ this checklist:
 
 =over 4
 
-=item What version of perl you are running?
+=item What version of Perl you are running?
 
 Type C<perl -v> at the command line to find out.
 
@@ -886,16 +966,16 @@ Type C<perl -v> at the command line to find out.
 
 Look at http://www.perl.com/ to find out.  If it is not the latest
 released version, get that one and see whether your bug has been
-fixed.  Note that bug reports about old versions of perl, especially
+fixed.  Note that bug reports about old versions of Perl, especially
 those prior to the 5.0 release, are likely to fall upon deaf ears.
 You are on your own if you continue to use perl1 .. perl4.
 
 =item Are you sure what you have is a bug?
 
 A significant number of the bug reports we get turn out to be documented
-features in perl.  Make sure the behavior you are witnessing doesn't fall
+features in Perl.  Make sure the behavior you are witnessing doesn't fall
 under that category, by glancing through the documentation that comes
-with perl (we'll admit this is no mean task, given the sheer volume of
+with Perl (we'll admit this is no mean task, given the sheer volume of
 it all, but at least have a look at the sections that I<seem> relevant).
 
 Be aware of the familiar traps that perl programmers of various hues
@@ -905,10 +985,10 @@ Check in L<perldiag> to see what any Perl error message(s) mean.
 If message isn't in perldiag, it probably isn't generated by Perl.
 Consult your operating system documentation instead.
 
-If you are on a non-UNIX platform check also L<perlport>, some
-features may not be implemented or work differently.
+If you are on a non-UNIX platform check also L<perlport>, as some
+features may be unimplemented or work differently.
 
-Try to study the problem under the perl debugger, if necessary.
+Try to study the problem under the Perl debugger, if necessary.
 See L<perldebug>.
 
 =item Do you have a proper test case?
@@ -930,7 +1010,7 @@ 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, not
+because it will most probably contain only the function names and not
 their arguments.  If possible, recompile your Perl with debug info and
 reproduce the dump and the stack trace.
 
@@ -938,8 +1018,8 @@ reproduce the dump and the stack trace.
 
 The easier it is to understand a reproducible bug, the more likely it
 will be fixed.  Anything you can provide by way of insight into the
-problem helps a great deal.  In other words, try to analyse the
-problem to the extent you feel qualified and report your discoveries.
+problem helps a great deal.  In other words, try to analyze the
+problem (to the extent you can) and report your discoveries.
 
 =item Can you fix the bug yourself?
 
@@ -973,14 +1053,14 @@ 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 informative.  "a bug" not informative.  Neither is "perl
-crashes" nor "HELP!!!", these all are null information.  A compact
-description of what's wrong is fine.
+your Subject line informative.  "a bug" not informative.  Neither is
+"perl crashes" nor "HELP!!!".  These don't help.
+A compact description of what's wrong is fine.
 
 =back
 
 Having done your bit, please be prepared to wait, to be told the bug
-is in your code, or even to get no reply at all.  The perl maintainers
+is in your code, or even to get no reply at all.  The Perl maintainers
 are busy folks, so if your problem is a small one or if it is difficult
 to understand or already known, they may not respond with a personal reply.
 If it is important to you that your bug be fixed, do monitor the
@@ -1091,12 +1171,14 @@ Include verbose configuration data in the report.
 =head1 AUTHORS
 
 Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored
-by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen
+by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>), Tom Christiansen
 (E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>),
 Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy
 (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>),
-Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>), and
-Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>).
+Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>),
+Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
+(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
+and Richard Foley (E<lt>richard@rfi.netE<gt>).
 
 =head1 SEE ALSO
 
diff --git a/gnu/usr.bin/perl/utils/perldoc.PL b/gnu/usr.bin/perl/utils/perldoc.PL
index 26335101c01..32421d77c20 100644
--- a/gnu/usr.bin/perl/utils/perldoc.PL
+++ b/gnu/usr.bin/perl/utils/perldoc.PL
@@ -30,39 +30,49 @@ $Config{startperl}
     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
 	if 0;
 
+use warnings;
 use strict;
+
+# make sure creat()s are neither too much nor too little
+INIT { eval { umask(0077) } }   # doubtless someone has no mask
+
 my \@pagers = ();
 push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
+
 !GROK!THIS!
 
 # In the following, perl variables are not expanded during extraction.
 
 print OUT <<'!NO!SUBS!';
 
+use Fcntl;    # for sysopen
+use Getopt::Std;
+use Config '%Config';
+
 #
 # Perldoc revision #1 -- look up a piece of documentation in .pod format that
 # is embedded in the perl installation tree.
 #
-# This is not to be confused with Tom Christianson's perlman, which is a
+# This is not to be confused with Tom Christiansen's perlman, which is a
 # man replacement, written in perl. This perldoc is strictly for reading
 # the perl manuals, though it too is written in perl.
+# 
+# Massive security and correctness patches applied to this
+# noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000 
 
-if(@ARGV<1) {
+if (@ARGV<1) {
 	my $me = $0;		# Editing $0 is unportable
 	$me =~ s,.*/,,;
 	die <<EOF;
-Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName
+Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName
        $me -f PerlFunc
        $me -q FAQKeywords
 
 The -h option prints more help.  Also try "perldoc perldoc" to get
-aquainted with the system.
+acquainted with the system.
 EOF
 }
 
-use Getopt::Std;
-use Config '%Config';
-
 my @global_found = ();
 my $global_target = "";
 
@@ -82,22 +92,24 @@ perldoc [options] -q FAQRegex
 Options:
     -h   Display this help message
     -r   Recursive search (slow)
-    -i   Ignore case 
+    -i   Ignore case
     -t   Display pod using pod2text instead of pod2man and nroff
              (-t is the default on win32)
     -u	 Display unformatted pod text
     -m   Display module's file in its entirety
+    -n   Specify replacement for nroff
     -l   Display the module's file name
     -F   Arguments are file names, not modules
     -v	 Verbosely describe what's going on
     -X	 use index if present (looks for pod.idx at $Config{archlib})
     -q   Search the text of questions (not answers) in perlfaq[1-9]
+    -U	 Run in insecure mode (superuser only)
 
 PageName|ModuleName...
-         is the name of a piece of documentation that you want to look at. You 
+         is the name of a piece of documentation that you want to look at. You
          may either give a descriptive name of the page (as in the case of
-         `perlfunc') the name of a module, either like `Term::Info', 
-         `Term/Info', the partial name of a module, like `info', or 
+         `perlfunc') the name of a module, either like `Term::Info',
+         `Term/Info', the partial name of a module, like `info', or
          `makemaker', or the name of a program, like `perldoc'.
 
 BuiltinFunction
@@ -108,20 +120,20 @@ FAQRegex
          is a regex. Will search perlfaq[1-9] for and extract any
          questions that match.
 
-Any switches in the PERLDOC environment variable will be used before the 
+Any switches in the PERLDOC environment variable will be used before the
 command line arguments.  The optional pod index file contains a list of
 filenames, one per line.
 
 EOF
 }
 
-if( defined $ENV{"PERLDOC"} ) {
+if (defined $ENV{"PERLDOC"}) {
     require Text::ParseWords;
     unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
 }
 !NO!SUBS!
 
-my $getopts = "mhtluvriFf:Xq:";
+my $getopts = "mhtluvriFf:Xq:n:U";
 print OUT <<"!GET!OPTS!";
 
 use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
@@ -133,75 +145,105 @@ print OUT <<'!NO!SUBS!';
 
 usage if $opt_h;
 
+# refuse to run if we should be tainting and aren't
+# (but regular users deserve protection too, though!)
+if (!($Is_VMS || $Is_MSWin32 || $Is_Dos) && ($> == 0 || $< == 0)
+     && !am_taint_checking()) 
+{{
+    if ($opt_U) {
+        my $id = eval { getpwnam("nobody") };
+           $id = eval { getpwnam("nouser") } unless defined $id;
+           $id = -2 unless defined $id;
+        eval {
+            $> = $id;  # must do this one first!
+            $< = $id;
+        };
+        last if !$@ && $< && $>;
+    }
+    die "Superuser must not run $0 without security audit and taint checks.\n";
+}}
+
+$opt_n = "nroff" if !$opt_n;
+
 my $podidx;
-if( $opt_X ) {
+if ($opt_X) {
     $podidx = "$Config{'archlib'}/pod.idx";
     $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
 }
 
-if( (my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
+if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
     usage("only one of -t, -u, -m or -l")
-} elsif ($Is_MSWin32 || $Is_Dos) {
-    $opt_t = 1 unless $opts
+}
+elsif ($Is_MSWin32
+       || $Is_Dos
+       || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
+{
+    $opt_t = 1 unless $opts;
 }
 
 if ($opt_t) { require Pod::Text; import Pod::Text; }
 
 my @pages;
 if ($opt_f) {
-   @pages = ("perlfunc");
-} elsif ($opt_q) {
-   @pages = ("perlfaq1" .. "perlfaq9");
-} else {
-   @pages = @ARGV;
+    @pages = ("perlfunc");
+}
+elsif ($opt_q) {
+    @pages = ("perlfaq1" .. "perlfaq9");
+}
+else {
+    @pages = @ARGV;
 }
 
 # Does this look like a module or extension directory?
 if (-f "Makefile.PL") {
-	# Add ., lib and blib/* libs to @INC (if they exist)
-	unshift(@INC, '.');
-	unshift(@INC, 'lib') if -d 'lib';
-	require ExtUtils::testlib;
-}
 
+    # Add ., lib to @INC (if they exist)
+    eval q{ use lib qw(. lib); 1; } or die;
 
+    # don't add if superuser
+    if ($< && $>) {   # don't be looking too hard now!
+	eval q{ use blib; 1 } or die;
+    }
+}
 
 sub containspod {
     my($file, $readit) = @_;
-    return 1 if !$readit && $file =~ /\.pod$/i;
+    return 1 if !$readit && $file =~ /\.pod\z/i;
     local($_);
-    open(TEST,"<$file");
-    while(<TEST>) {
-	if(/^=head/) {
-	    close(TEST);
+    open(TEST,"<", $file) 	or die "Can't open $file: $!";
+    while (<TEST>) {
+	if (/^=head/) {
+	    close(TEST) 	or die "Can't close $file: $!";
 	    return 1;
 	}
     }
-    close(TEST);
+    close(TEST) 		or die "Can't close $file: $!";
     return 0;
 }
 
 sub minus_f_nocase {
      my($dir,$file) = @_;
-     my $path = join('/',$dir,$file);
+     my $path = join('/',$dir,$file);	# XXX: dirseps
      return $path if -f $path and -r _;
      if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
-        # on a case-forgiving file system or if case is important 
+        # on a case-forgiving file system or if case is important
 	# that is it all we can do
 	warn "Ignored $path: unreadable\n" if -f _;
 	return '';
      }
      local *DIR;
+     # this is completely wicked.  don't mess with $", and if 
+     # you do, don't assume / is the dirsep!
      local($")="/";
      my @p = ($dir);
      my($p,$cip);
-     foreach $p (split(/\//, $file)){
+     foreach $p (split(m!/!, $file)){	# XXX: dirseps
 	my $try = "@p/$p";
 	stat $try;
- 	if (-d _){
+ 	if (-d _) {
  	    push @p, $p;
 	    if ( $p eq $global_target) {
-		my $tmp_path = join ('/', @p);
+		my $tmp_path = join ('/', @p);  # XXX: dirseps
 		my $path_f = 0;
 		for (@global_found) {
 		    $path_f = 1 if $_ eq $tmp_path;
@@ -209,21 +251,24 @@ sub minus_f_nocase {
 		push (@global_found, $tmp_path) unless $path_f;
 		print STDERR "Found as @p but directory\n" if $opt_v;
 	    }
- 	} elsif (-f _ && -r _) {
+ 	}
+	elsif (-f _ && -r _) {
  	    return $try;
- 	} elsif (-f _) {
+ 	}
+	elsif (-f _) {
 	    warn "Ignored $try: unreadable\n";
- 	} else {
+ 	}
+	elsif (-d "@p") {
  	    my $found=0;
  	    my $lcp = lc $p;
- 	    opendir DIR, "@p";
+ 	    opendir DIR, "@p" 	    or die "opendir @p: $!";
  	    while ($cip=readdir(DIR)) {
  		if (lc $cip eq $lcp){
  		    $found++;
  		    last;
  		}
  	    }
- 	    closedir DIR;
+ 	    closedir DIR	    or die "closedir @p: $!";
  	    return "" unless $found;
  	    push @p, $cip;
  	    return "@p" if -f "@p" and -r _;
@@ -232,13 +277,15 @@ sub minus_f_nocase {
      }
      return "";
 }
- 
+
 
 sub check_file {
     my($dir,$file) = @_;
+    return "" if length $dir and not -d $dir;
     if ($opt_m) {
 	return minus_f_nocase($dir,$file);
-    } else {
+    }
+    else {
 	my $path = minus_f_nocase($dir,$file);
         return $path if length $path and containspod($path);
     }
@@ -255,35 +302,38 @@ sub searchfor {
     my $ret;
     my $i;
     my $dir;
-    $global_target = (split('/', $s))[-1];
+    $global_target = (split(m!/!, $s))[-1];   # XXX: dirseps
     for ($i=0; $i<@dirs; $i++) {
 	$dir = $dirs[$i];
-	($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
+	($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
 	if (       ( $ret = check_file $dir,"$s.pod")
 		or ( $ret = check_file $dir,"$s.pm")
 		or ( $ret = check_file $dir,$s)
 		or ( $Is_VMS and
 		     $ret = check_file $dir,"$s.com")
-		or ( $^O eq 'os2' and 
+		or ( $^O eq 'os2' and
 		     $ret = check_file $dir,"$s.cmd")
 		or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
 		     $ret = check_file $dir,"$s.bat")
 		or ( $ret = check_file "$dir/pod","$s.pod")
 		or ( $ret = check_file "$dir/pod",$s)
+		or ( $ret = check_file "$dir/pods","$s.pod")
+		or ( $ret = check_file "$dir/pods",$s)
 	) {
 	    return $ret;
 	}
-	
+
 	if ($recurse) {
-	    opendir(D,$dir);
-	    my @newdirs = map "$dir/$_", grep {
-		not /^\.\.?$/ and
-		not /^auto$/  and   # save time! don't search auto dirs
-		-d  "$dir/$_"
+	    opendir(D,$dir)	or die "Can't opendir $dir: $!";
+	    my @newdirs = map "$dir/$_", grep {  # XXX: dirseps
+		not /^\.\.?\z/s and
+		not /^auto\z/s  and   # save time! don't search auto dirs
+		-d  "$dir/$_"  # XXX: dirseps
 	    } readdir D;
-	    closedir(D);
+	    closedir(D)		or die "Can't closedir $dir: $!";
 	    next unless @newdirs;
-	    @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS;
+	    # what a wicked map!
+	    @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
 	    print STDERR "Also looking in @newdirs\n" if $opt_v;
 	    push(@dirs,@newdirs);
 	}
@@ -291,73 +341,155 @@ sub searchfor {
     return ();
 }
 
+sub filter_nroff {
+  my @data = split /\n{2,}/, shift;
+  shift @data while @data and $data[0] !~ /\S/; # Go to header
+  shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
+  pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
+				# 28/Jan/99 perl 5.005, patch 53 1
+  join "\n\n", @data;
+}
+
+sub printout {
+    my ($file, $tmp, $filter) = @_;
+    my $err;
+
+    if ($opt_t) {
+	# why was this append?
+	sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
+	    or die ("Can't open $tmp: $!");
+	Pod::Text->new()->parse_from_file($file,\*OUT);
+	close OUT   or die "can't close $tmp: $!";
+    }
+    elsif (not $opt_u) {
+	my $cmd = "pod2man --lax $file | $opt_n -man";
+	$cmd .= " | col -x" if $^O =~ /hpux/;
+	my $rslt = `$cmd`;
+	$rslt = filter_nroff($rslt) if $filter;
+	unless (($err = $?)) {
+	    # why was this append?
+	    sysopen(TMP, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
+		or die "Can't open $tmp: $!";
+	    print TMP $rslt
+		or die "Can't print $tmp: $!";
+	    close TMP
+		or die "Can't close $tmp: $!";
+	}
+    }
+    if ($opt_u or $err or -z $tmp) {  # XXX: race with -z
+	# why was this append?
+	sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
+	    or die "Can't open $tmp: $!";
+	open(IN,"<", $file)   or die("Can't open $file: $!");
+	my $cut = 1;
+	local $_;
+	while (<IN>) {
+	    $cut = $1 eq 'cut' if /^=(\w+)/;
+	    next if $cut;
+	    print OUT
+		or die "Can't print $tmp: $!";
+	}
+	close IN    or die "Can't close $file: $!";
+	close OUT   or die "Can't close $tmp: $!";
+    }
+}
+
+sub page {
+    my ($tmp, $no_tty, @pagers) = @_;
+    if ($no_tty) {
+	open(TMP,"<", $tmp) 	or die "Can't open $tmp: $!";
+	local $_;
+	while (<TMP>) {
+	    print or die "Can't print to stdout: $!";
+	} 
+	close TMP		or die "Can't close while $tmp: $!";
+    }
+    else {
+	foreach my $pager (@pagers) {
+	    last if system("$pager $tmp") == 0;
+	}
+    }
+}
+
+sub cleanup {
+    my @files = @_;
+    for (@files) {
+	if ($Is_VMS) { 
+	    1 while unlink($_);    # XXX: expect failure
+	} else {
+	    unlink($_);		   # or die "Can't unlink $_: $!";
+	} 
+    }
+}
+
 my @found;
 foreach (@pages) {
-        if ($podidx && open(PODIDX, $podidx)) {
-	    my $searchfor = $_;
-	    local($_);
-	    $searchfor =~ s,::,/,g;
-	    print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
-	    while (<PODIDX>) {
-		chomp;
-		push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i;
-	    }
-	    close(PODIDX);
-	    next;
-        }
-	print STDERR "Searching for $_\n" if $opt_v;
-	# We must look both in @INC for library modules and in PATH
-	# for executables, like h2xs or perldoc itself.
-	my @searchdirs = @INC;
-	if ($opt_F) {
-	  next unless -r;
-	  push @found, $_ if $opt_m or containspod($_);
-	  next;
+    if ($podidx && open(PODIDX, $podidx)) {
+	my $searchfor = $_;
+	$searchfor =~ s,::,/,g;	    # XXX: dirseps
+	print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
+	local $_;
+	while (<PODIDX>) {
+	    chomp;
+	    push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
 	}
-	unless ($opt_m) { 
-	    if ($Is_VMS) {
-		my($i,$trn);
-		for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
-		    push(@searchdirs,$trn);
-		}
-		push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
-	    } else {
-	        push(@searchdirs, grep(-d, split($Config{path_sep}, 
-						 $ENV{'PATH'})));
+	close(PODIDX)	    or die "Can't close $podidx: $!";
+	next;
+    }
+    print STDERR "Searching for $_\n" if $opt_v;
+    # We must look both in @INC for library modules and in PATH
+    # for executables, like h2xs or perldoc itself.
+    my @searchdirs = @INC;
+    if ($opt_F) {
+	next unless -r;
+	push @found, $_ if $opt_m or containspod($_);
+	next;
+    }
+    unless ($opt_m) {
+	if ($Is_VMS) {
+	    my($i,$trn);
+	    for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
+		push(@searchdirs,$trn);
 	    }
+	    push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
 	}
-	my @files = searchfor(0,$_,@searchdirs);
-	if( @files ) {
-		print STDERR "Found as @files\n" if $opt_v;
-	} else {
-		# no match, try recursive search
-		
-		@searchdirs = grep(!/^\.$/,@INC);
-		
-		@files= searchfor(1,$_,@searchdirs) if $opt_r;
-		if( @files ) {
-			print STDERR "Loosely found as @files\n" if $opt_v;
-		} else {
-			print STDERR "No documentation found for \"$_\".\n";
-			if (@global_found) {
-			    print STDERR "However, try\n";
-			    for my $dir (@global_found) {
-				opendir(DIR, $dir) or die "$!";
-				while (my $file = readdir(DIR)) {
-				    next if ($file =~ /^\./);
-				    $file =~ s/\.(pm|pod)$//;
-				    print STDERR "\tperldoc $_\::$file\n";
-				}
-				closedir DIR;
-			    }
-			}
+	else {
+	    push(@searchdirs, grep(-d, split($Config{path_sep},
+					     $ENV{'PATH'})));
+	}
+    }
+    my @files = searchfor(0,$_,@searchdirs);
+    if (@files) {
+	print STDERR "Found as @files\n" if $opt_v;
+    }
+    else {
+	# no match, try recursive search
+	@searchdirs = grep(!/^\.\z/s,@INC);
+	@files= searchfor(1,$_,@searchdirs) if $opt_r;
+	if (@files) {
+	    print STDERR "Loosely found as @files\n" if $opt_v;
+	}
+	else {
+	    print STDERR "No documentation found for \"$_\".\n";
+	    if (@global_found) {
+		print STDERR "However, try\n";
+		for my $dir (@global_found) {
+		    opendir(DIR, $dir) or die "opendir $dir: $!";
+		    while (my $file = readdir(DIR)) {
+			next if ($file =~ /^\./s);
+			$file =~ s/\.(pm|pod)\z//;  # XXX: badfs
+			print STDERR "\tperldoc $_\::$file\n";
+		    }
+		    closedir DIR    or die "closedir $dir: $!";
 		}
+	    }
 	}
-	push(@found,@files);
+    }
+    push(@found,@files);
 }
 
-if(!@found) {
-	exit ($Is_VMS ? 98962 : 1);
+if (!@found) {
+    exit ($Is_VMS ? 98962 : 1);
 }
 
 if ($opt_l) {
@@ -368,175 +500,181 @@ if ($opt_l) {
 my $lines = $ENV{LINES} || 24;
 
 my $no_tty;
-if( ! -t STDOUT ) { $no_tty = 1 }
+if (! -t STDOUT) { $no_tty = 1 }
+END { close(STDOUT) || die "Can't close STDOUT: $!" }
+
+# until here we could simply exit or die
+# now we create temporary files that we have to clean up
+# namely $tmp, $buffer
+# that's because you did it wrong, should be descriptor based --tchrist
 
 my $tmp;
+my $buffer;
 if ($Is_MSWin32) {
-	$tmp = "$ENV{TEMP}\\perldoc1.$$";
-	push @pagers, qw( more< less notepad );
-	unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
-} elsif ($Is_VMS) {
-	$tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
-	push @pagers, qw( most more less type/page );
-} elsif ($Is_Dos) {
-	$tmp = "$ENV{TEMP}/perldoc1.$$";
-	$tmp =~ tr!\\/!//!s;
-	push @pagers, qw( less.exe more.com< );
-	unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
-} else {
-	if ($^O eq 'os2') {
-	  require POSIX;
-	  $tmp = POSIX::tmpnam();
-	  unshift @pagers, 'less', 'cmd /c more <';
-	} else {
-	  $tmp = "/tmp/perldoc1.$$";	  
-	}
-	push @pagers, qw( more less pg view cat );
-	unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
+    $tmp = "$ENV{TEMP}\\perldoc1.$$";
+    $buffer = "$ENV{TEMP}\\perldoc1.b$$";
+    push @pagers, qw( more< less notepad );
+    unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
+    for (@found) { s,/,\\,g }
+}
+elsif ($Is_VMS) {
+    $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
+    $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$;
+    push @pagers, qw( most more less type/page );
+}
+elsif ($Is_Dos) {
+    $tmp = "$ENV{TEMP}/perldoc1.$$";
+    $buffer = "$ENV{TEMP}/perldoc1.b$$";
+    $tmp =~ tr!\\/!//!s;
+    $buffer =~ tr!\\/!//!s;
+    push @pagers, qw( less.exe more.com< );
+    unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
+}
+else {
+    if ($^O eq 'os2') {
+      require POSIX;
+      $tmp = POSIX::tmpnam();
+      $buffer = POSIX::tmpnam();
+      unshift @pagers, 'less', 'cmd /c more <';
+    }
+    else {
+      # XXX: this is not secure, because it doesn't open it
+      ($tmp, $buffer) = eval { require POSIX } 
+	    ? (POSIX::tmpnam(),    POSIX::tmpnam()     )
+	    : ("/tmp/perldoc1.$$", "/tmp/perldoc1.b$$" );
+    }
+    push @pagers, qw( more less pg view cat );
+    unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 }
 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 
+# make sure cleanup called
+eval q{
+    sub END { cleanup($tmp, $buffer) } 
+    1;
+} || die;
+eval q{ use sigtrap qw(die INT TERM HUP QUIT) };
+
 if ($opt_m) {
-	foreach my $pager (@pagers) {
-		system("$pager @found") or exit;
-	}
-	if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
-	exit 1;
-} 
+    foreach my $pager (@pagers) {
+	if (system($pager, @found) == 0) {
+	    exit;
+    }
+    }
+    if ($Is_VMS) { 
+	eval q{
+	    use vmsish qw(status exit); 
+	    exit $?;
+	    1;
+	} or die;
+    }
+    exit(1);
+}
 
+my @pod;
 if ($opt_f) {
-   my $perlfunc = shift @found;
-   open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
-
-   # Functions like -r, -e, etc. are listed under `-X'.
-   my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) ? 'I<-X' : $opt_f ;
-
-   # Skip introduction
-   while (<PFUNC>) {
-       last if /^=head2 Alphabetical Listing of Perl Functions/;
-   }
-
-   # Look for our function
-   my $found = 0;
-   my @pod;
-   while (<PFUNC>) {
-       if (/^=item\s+\Q$search_string\E\b/o)  {
-	   $found = 1;
-       } elsif (/^=item/) {
-	   last if $found > 1;
-       }
-       next unless $found;
-       push @pod, $_;
-       ++$found if /^\w/;	# found descriptive text
-   }
-   if (@pod) {
-       if ($opt_t) {
-	   open(FORMATTER, "| pod2text") || die "Can't start filter";
-	   print FORMATTER "=over 8\n\n";
-	   print FORMATTER @pod;
-	   print FORMATTER "=back\n";
-	   close(FORMATTER);
-       } elsif (@pod < $lines-2) {
-	   print @pod;
-       } else {
-	   foreach my $pager (@pagers) {
-		open (PAGER, "| $pager") or next;
-		print PAGER @pod ;
-		close(PAGER) or next;
-		last;
-	   }
-       }
-   } else {
-       die "No documentation for perl function `$opt_f' found\n";
-   }
-   exit;
+    my $perlfunc = shift @found;
+    open(PFUNC, "<", $perlfunc)
+	or die("Can't open $perlfunc: $!");
+
+    # Functions like -r, -e, etc. are listed under `-X'.
+    my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
+			? 'I<-X' : $opt_f ;
+
+    # Skip introduction
+    local $_;
+    while (<PFUNC>) {
+	last if /^=head2 Alphabetical Listing of Perl Functions/;
+    }
+
+    # Look for our function
+    my $found = 0;
+    my $inlist = 0;
+    while (<PFUNC>) {
+	if (/^=item\s+\Q$search_string\E\b/o)  {
+	    $found = 1;
+	}
+	elsif (/^=item/) {
+	    last if $found > 1 and not $inlist;
+	}
+	next unless $found;
+	if (/^=over/) {
+	    ++$inlist;
+	}
+	elsif (/^=back/) {
+	    --$inlist;
+	}
+	push @pod, $_;
+	++$found if /^\w/;	# found descriptive text
+    }
+    if (!@pod) {
+	die "No documentation for perl function `$opt_f' found\n";
+    }
+    close PFUNC		or die "Can't open $perlfunc: $!";
 }
 
 if ($opt_q) {
-   local @ARGV = @found;	# I'm lazy, sue me.
-   my $found = 0;
-   my %found_in;
-   my @pod;
-
-   while (<>) {
-      if (/^=head2\s+.*(?:$opt_q)/oi) {
-	 $found = 1;
-	 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
-      } elsif (/^=head2/) {
-	 $found = 0;
-      }
-      next unless $found;
-      push @pod, $_;
-   }
-   
-   if (@pod) {
-      if ($opt_t) {
-	 open(FORMATTER, "| pod2text") || die "Can't start filter";
-	 print FORMATTER "=over 8\n\n";
-	 print FORMATTER @pod;
-	 print FORMATTER "=back\n";
-	 close(FORMATTER);
-      } elsif (@pod < $lines-2) {
-	 print @pod;
-      } else {
-	 foreach my $pager (@pagers) {
-	    open (PAGER, "| $pager") or next;
-	    print PAGER @pod ;
-	    close(PAGER) or next;
-	    last;
-	 }
-      }
-   } else {
-      die "No documentation for perl FAQ keyword `$opt_q' found\n";
-   }
-   exit;
+    local @ARGV = @found;	# I'm lazy, sue me.
+    my $found = 0;
+    my %found_in;
+    my $rx = eval { qr/$opt_q/ } or die <<EOD;
+Invalid regular expression '$opt_q' given as -q pattern:
+  $@
+Did you mean \\Q$opt_q ?
+
+EOD
+
+    for (@found) { die "invalid file spec: $!" if /[<>|]/ } 
+    local $_;
+    while (<>) {
+	if (/^=head2\s+.*(?:$opt_q)/oi) {
+	    $found = 1;
+	    push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
+	}
+	elsif (/^=head2/) {
+	    $found = 0;
+	}
+	next unless $found;
+	push @pod, $_;
+    }
+    if (!@pod) {
+	die("No documentation for perl FAQ keyword `$opt_q' found\n");
+    }
 }
 
-foreach (@found) {
+my $filter;
+
+if (@pod) {
+    sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT)
+	or die("Can't open $buffer: $!");
+    print TMP "=over 8\n\n";
+    print TMP @pod	or die "Can't print $buffer: $!";
+    print TMP "=back\n";
+    close TMP		or die "Can't close $buffer: $!";
+    @found = $buffer;
+    $filter = 1;
+}
 
-	my $err;
-	if($opt_t) {
-		open(TMP,">>$tmp");
-		Pod::Text::pod2text($_,*TMP);
-		close(TMP);
-	} elsif(not $opt_u) {
-		my $cmd = "pod2man --lax $_ | nroff -man";
-		$cmd .= " | col -x" if $^O =~ /hpux/;
-		my $rslt = `$cmd`;
-		unless(($err = $?)) {
-			open(TMP,">>$tmp");
-			print TMP $rslt;
-			close TMP;
-		}
-	}
-	                                                
-	if( $opt_u or $err or -z $tmp) {
-		open(OUT,">>$tmp");
-		open(IN,"<$_");
-		my $cut = 1;
-		while (<IN>) {
-			$cut = $1 eq 'cut' if /^=(\w+)/;
-			next if $cut;
-			print OUT;
-		}
-		close(IN);
-		close(OUT);
-	}
+foreach (@found) {
+    printout($_, $tmp, $filter);
 }
+page($tmp, $no_tty, @pagers);
 
-if( $no_tty ) {
-	open(TMP,"<$tmp");
-	print while <TMP>;
-	close(TMP);
-} else {
-	foreach my $pager (@pagers) {
-		system("$pager $tmp") or last;
-	}
+exit;
+
+sub is_tainted {
+    my $arg = shift;
+    my $nada = substr($arg, 0, 0);  # zero-length
+    local $@;  # preserve caller's version
+    eval { eval "# $nada" };
+    return length($@) != 0;
 }
 
-1 while unlink($tmp); #Possibly pointless VMSism
+sub am_taint_checking {
+    my($k,$v) = each %ENV;
+    return is_tainted($v);  
+}
 
-exit 0;
 
 __END__
 
@@ -616,11 +754,20 @@ The B<-X> option looks for a entry whose basename matches the name given on the
 command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
 contain fully qualified filenames, one per line.
 
+=item B<-U> run insecurely
+
+Because B<perldoc> does not run properly tainted, and is known to
+have security issues, it will not normally execute as the superuser.
+If you use the B<-U> flag, it will do so, but only after setting
+the effective and real IDs to nobody's or nouser's account, or -2
+if unavailable.  If it cannot relinguish its privileges, it will not
+run.  
+
 =item B<PageName|ModuleName|ProgramName>
 
 The item you want to look up.  Nested modules (such as C<File::Basename>)
 are specified either as C<File::Basename> or C<File/Basename>.  You may also
-give a descriptive name of a page, such as C<perlfunc>. You make also give a
+give a descriptive name of a page, such as C<perlfunc>. You may also give a
 partial or wrong-case name, such as "basename" for "File::Basename", but
 this will be slower, if there is more then one page with the same partial
 name, you will only get the first one.
@@ -629,7 +776,7 @@ name, you will only get the first one.
 
 =head1 ENVIRONMENT
 
-Any switches in the C<PERLDOC> environment variable will be used before the 
+Any switches in the C<PERLDOC> environment variable will be used before the
 command line arguments.  C<perldoc> also searches directories
 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 defined) and C<PATH> environment variables.
@@ -639,29 +786,48 @@ preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
 C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
 used if C<perldoc> was told to display plain text or unformatted pod.)
 
+One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
+
+=head1 VERSION
+
+This is perldoc v2.01.
+
 =head1 AUTHOR
 
 Kenneth Albanowski <kjahds@kjahds.com>
 
-Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
+Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
+and others.
 
 =cut
 
 #
+# Version 2.02: Mon Mar 13 18:03:04 MST 2000
+#       Tom Christiansen <tchrist@perl.com>
+#	Added -U insecurity option
+# Version 2.01: Sat Mar 11 15:22:33 MST 2000 
+#       Tom Christiansen <tchrist@perl.com>, querulously.
+#       Security and correctness patches.
+#       What a twisted bit of distasteful spaghetti code.
+# Version 2.0: ????
+# Version 1.15: Tue Aug 24 01:50:20 EST 1999
+#       Charles Wilson <cwilson@ece.gatech.edu>
+#	changed /pod/ directory to /pods/ for cygwin
+#         to support cygwin/win32
 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
 #       Robin Barker <rmb1@cise.npl.co.uk>
 #	-strict, -w cleanups
 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
-#       Gurusamy Sarathy <gsar@umich.edu>
+#       Gurusamy Sarathy <gsar@activestate.com>
 #	-doc tweaks for -F and -X options
 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
-#       Gurusamy Sarathy <gsar@umich.edu>
+#       Gurusamy Sarathy <gsar@activestate.com>
 #	-various fixes for win32
 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
 #       Kenneth Albanowski <kjahds@kjahds.com>
 #   -added Charles Bailey's further VMS patches, and -u switch
 #   -added -t switch, with pod2text support
-# 
+#
 # Version 1.10: Thu Nov  9 07:23:47 EST 1995
 #		Kenneth Albanowski <kjahds@kjahds.com>
 #	-added VMS support