Index: /other-projects/trunk/realistic-books/bin/script/checkwritability.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/script/checkwritability.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/script/checkwritability.bat	(revision 19631)
@@ -0,0 +1,75 @@
+@echo off
+
+if "%REALISTIC_BOOKS_HOME%" == "" goto EnvNotSet
+
+REM test if we have write permission on the greenstone install directory
+echo.
+echo Checking if REALISTIC_BOOKS_HOME is writable...
+echo This is a temporary file. It is safe to delete it. > "%REALISTIC_BOOKS_HOME%\books\testing.tmp"
+if not exist "%REALISTIC_BOOKS_HOME%\books\testing.tmp" goto CantWrite
+del "%REALISTIC_BOOKS_HOME%\books\testing.tmp"
+echo REALISTIC_BOOKS_HOME has write permission for the current user.
+echo.
+goto TheEnd
+
+:CantWrite
+echo.
+echo.
+echo.
+echo -----------------------------------
+
+if "%RBLANG%" == "en" echo  WARNING: CANNOT WRITE TO REALISTIC_BOOKS_HOME
+if "%RBLANG%" == "es" echo  ATENCIÃN: NO PUEDE ESCRIBIR EN EL DIRECTORIO RAÃZ DE GREENSTONE.
+if "%RBLANG%" == "fr" echo  AVERTISSEMENT: ECRIRE IMPOSSIBLE DANS LE DOSSIER D'ACCUEIL DE GREENSTONE
+if "%RBLANG%" == "ru" echo  ÐÐÐÐÐÐÐÐ: ÐÐÐÐÐÐÐÐÐÐ ÐÐ¡Ð£Ð©ÐÐ¡Ð¢ÐÐÐ¢Ð¬ ÐÐÐÐÐ¡Ð¬ Ð ÐÐÐÐÐšÐÐ®Ð® ÐÐÐÐÐ£ GREENSTONE
+
+echo -----------------------------------
+If "%RBLANG%" == "en" echo Greenstone needs write permission for the Greenstone home folder,
+if "%RBLANG%" == "en" echo which is %REALISTIC_BOOKS_HOME%,
+if "%RBLANG%" == "en" echo but right now it does not.
+if "%RBLANG%" == "en" echo Please grant "Full Control" for this folder (and all subfolders)  
+if "%RBLANG%" == "en" echo to the current user (%username%) and try again.
+
+if "%RBLANG%" == "es" echo Greenstone necesita permiso de escritura en el directorio:
+if "%RBLANG%" == "es" echo %REALISTIC_BOOKS_HOME%,
+if "%RBLANG%" == "es" echo pero no lo tiene.
+if "%RBLANG%" == "es" echo Por favor, concÃ©dale âControl completoâ al usuario actual (%username%), 
+if "%RBLANG%" == "es" echo y vuelva a intentarlo.
+
+if "%RBLANG%" == "fr" echo Greenstone nÃ©cessite une autorisation d'Ã©criture dans le dossier 
+if "%RBLANG%" == "fr" echo principal de Greenstone: %REALISTIC_BOOKS_HOME%,
+if "%RBLANG%" == "fr" echo mais pour l'instant cette autorisation n'existe pas.
+if "%RBLANG%" == "fr" echo Autorisez le Â«Â ContrÃŽle TotalÂ Â» sur ce dossier (et sur tous les sous-dossiers)
+if "%RBLANG%" == "fr" echo pour l'utilisateur courant (%username%) puis re-essayez.
+
+if "%RBLANG%" == "ru" echo Greenstone ÑÑÐµÐ±ÑÐµÑÑÑ ÑÐ°Ð·ÑÐµÑÐµÐœÐžÐµ ÐœÐ° Ð·Ð°Ð¿ÐžÑÑ Ð² ÐŽÐŸÐŒÐ°ÑÐœÑÑ Ð¿Ð°Ð¿ÐºÑ %REALISTIC_BOOKS_HOME%,
+if "%RBLANG%" == "ru" echo Ð² ÐŽÐ°ÐœÐœÑÐ¹ ÐŒÐŸÐŒÐµÐœÑ Ð·Ð°Ð¿ÐžÑÑ Ð² ÐŽÐŸÐŒÐ°ÑÐœÑÑ Ð¿Ð°Ð¿ÐºÑ Ð·Ð°Ð¿ÑÐµÑÐµÐœÐ°.
+if "%RBLANG%" == "ru" echo ÐÐŸÐ¶Ð°Ð»ÑÐ¹ÑÑÐ° ÑÑÑÐ°ÐœÐŸÐ²ÐžÑÐµ ÐÐŸÐ»ÐœÑÐ¹ ÐŽÐŸÑÑÑÐ¿ ÐŽÐ»Ñ Ð¿Ð°Ð¿ÐºÐž (Ðž Ð²ÑÐµÑ
+ Ð²Ð»ÐŸÐ¶ÐµÐœÐœÑÑ
+ Ð¿Ð°Ð¿ÐŸÐº)
+if "%RBLANG%" == "ru" echo ÐŽÐ»Ñ ÑÐµÐºÑÑÐµÐ³ÐŸ Ð¿ÐŸÐ»ÑÐ·ÐŸÐ²Ð°ÑÐµÐ»Ñ (%username%) Ðž Ð¿ÐŸÐ¿ÑÐŸÐ±ÑÐ¹ÑÐµ Ð·Ð°ÐœÐŸÐ²ÐŸ.
+
+echo.
+
+if "%RBLANG%" == "en" echo (Alternatively, re-install Greenstone to a location where you have Full
+if "%RBLANG%" == "en" echo Control already, such as a your home folder or 'My Documents'.)
+
+if "%RBLANG%" == "es" echo (Alternativamente, reinstale Greenstone en una localizaciÃ³n en la que tenga âControl completoâ, 
+if "%RBLANG%" == "es" echo como su directorio raÃ­z o âMis documentosâ).
+
+if "%RBLANG%" == "fr" echo (Alternativement, re-installez Greenstone Ã  l'emplacement oÃ¹ vous avez dÃ©jÃ  le Â«Â ContrÃŽle TotalÂ Â», 
+if "%RBLANG%" == "fr" echo comme votre dossier d'accueil ou  "Mes Documents".)
+
+if "%RBLANG%" == "ru" echo (ÐÐžÐ±ÐŸ, Ð¿ÐµÑÐµÑÑÑÐ°ÐœÐŸÐ²ÐžÑÐµ Greenstone Ð² ÑÑ Ð¿Ð°Ð¿ÐºÑ, Ðº ÐºÐŸÑÐŸÑÐŸÐ¹ ÐÑ ÑÐ¶Ðµ ÐžÐŒÐµÐµÑÐµ Ð¿ÐŸÐ»ÐœÑÐ¹ ÐŽÐŸÑÑÑÐ¿, 
+if "%RBLANG%" == "ru" echo ÐœÐ°Ð¿ÑÐžÐŒÐµÑ Ð² ÑÐ²ÐŸÑ ÐŽÐŸÐŒÐ°ÑÐœÑÑ Ð¿Ð°Ð¿ÐºÑ ÐžÐ»Ðž Ð² Ð¿Ð°Ð¿ÐºÑ "ÐÐŸÐž ÐŽÐŸÐºÑÐŒÐµÐœÑÑ".)
+
+echo.
+echo.
+echo.
+echo.
+goto TheEnd
+
+:EnvNotSet
+echo REALISTIC_BOOKS_HOME not set
+
+:TheEnd
Index: /other-projects/trunk/realistic-books/bin/script/pdf2realbook.pl
===================================================================
--- /other-projects/trunk/realistic-books/bin/script/pdf2realbook.pl	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/script/pdf2realbook.pl	(revision 19631)
@@ -0,0 +1,206 @@
+#!/usr/bin/perl -w
+#
+# A component of the Realistic Book software
+# from the New Zealand Digital Library Project at the 
+# University of Waikato, New Zealand.
+#
+# Copyright (C) 2007 New Zealand Digital Library Project
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+
+#*****************************************************************
+#Realistic Book application
+#	Converting each PDF page into a SWF file. Also produce
+#	the XHTML input file for the Realistic book program
+#
+#by Veronica Liesaputra --- 1 August 2007
+#*****************************************************************/
+
+use warnings; 
+use strict;
+
+use File::Basename;
+use File::Spec::Functions;
+use File::Copy;
+
+BEGIN {
+    die "REALISTIC_BOOKS_HOME not set. Have you sourced setup.bash?\n" 
+	unless defined $ENV{'REALISTIC_BOOKS_HOME'};
+    die "RBOS not set. Have you sourced setup.bash?\n" 
+	unless defined $ENV{'RBOS'};
+}
+
+
+sub print_usage
+{
+    my ($full_progname) = @_;
+
+    my $progname = basename($full_progname);
+
+    print STDERR "\nUsage: $progname pdf_filename\n";
+    print STDERR "or     perl -S $progname pdf_filename\n\n";
+
+    exit(-1);
+}
+
+sub check_pdf2swf
+{
+    my $output = `pdf2swf --version`;
+
+    if (!defined $output || ($output !~ m/swftools/i)) {
+	print STDERR "Unable to find pdf2swf: $!\n";
+	print STDERR "Have you sourced setup.bash (Linux/MacOS)?\n";
+	print STDERR "Have you run     setup.bat  (Windows)?\n";
+	exit(-1);
+    }
+}
+
+sub check_file
+{
+    my ($filename) = @_;
+
+    if (-d $filename) {
+	print STDERR "Error: $filename is a directory.\n";
+	print STDERR "       Please specify the PDF file as input.\n";
+	exit(-1);
+    }
+
+    if (!-e $filename) {
+	print STDERR "Error: Unable to find $filename\n";
+	exit(-1);
+    }
+}
+
+sub copy_model_col
+{
+    my ($folder_name) = @_;
+
+    #--
+    # Copy modelcol content to new book folder
+    # --
+
+    mkdir($folder_name);
+    my $modelcol_dir = catfile($ENV{'REALISTIC_BOOKS_HOME'},"books","modelcol");
+    opendir(DIR, $modelcol_dir) 
+	|| die "Cannot open directory $modelcol_dir: $!";
+
+    my @model_files = grep { -f catfile($modelcol_dir,$_) } readdir(DIR);
+    closedir DIR;
+
+    foreach my $f ( @model_files) {
+	my $src_filename = catfile($modelcol_dir,$f);
+	my $dst_filename = catfile($folder_name,$f);
+	copy($src_filename,$dst_filename);
+    }
+}
+
+sub pdf2swf_info
+{
+    my ($filename) = @_;
+
+    my $cmd = "pdf2swf --info $filename";
+    if ($ENV{'RBOS'} =~ /^windows$/i) {
+	$cmd .= " 2>null";
+    }
+    else {
+	$cmd .= " 2>/dev/null";
+    }
+    
+    my @output_lines = split(/\n/,`$cmd`);
+
+    my $last_line = pop(@output_lines);
+
+    # Watch out for trailing \n
+    $last_line = pop(@output_lines) if ($last_line =~ m/^$/);
+
+    my ($num_pages) = ($last_line =~ m/^page=(\d+)/);
+
+    return $num_pages;
+}
+
+    
+sub generate_html
+{
+    my ($full_folder_name,$folder_root,$filename) = @_;
+
+    my $num_pages = pdf2swf_info($filename);
+    print STDOUT "Total page: $num_pages\n";
+
+    my $html_input = "<HTML>\n<title>$folder_root</title>\n<Description>\n";
+    $html_input = "$html_input<!-- Please do not remove Filename and PageFolder metadata -->\n";
+    $html_input = "$html_input<Metadata name=\"Filename\">$folder_root</Metadata>\n";
+    $html_input = "$html_input<Metadata name=\"PageFolder\">.</Metadata>\n";
+    $html_input = "$html_input<Metadata name=\"StartNumbering\">1</Metadata>\n";
+    $html_input = "$html_input</Description>\n";
+
+    for (my $i=1; $i<=$num_pages; $i++) {
+
+	my $backFile = "Page_$i.swf";
+	my $frontFile = "$full_folder_name";
+	my $output_file = catfile($frontFile,$backFile);
+	my $imgfile = `pdf2swf -p $i -s insertstop -s zoom=100 $filename -o $output_file`;
+	
+	print STDOUT "creating page $i\n";
+	
+	$html_input = "$html_input<newpage filename=\"Page_$i\" />\n";
+    }
+
+    $html_input = "$html_input</HTML>\n";
+
+    return $html_input;
+}
+
+
+sub main
+{
+    my ($argc,@argv) = @_;
+
+    my $full_progname = $0;
+
+    if ($argc < 0) {
+	print_usage($full_progname);
+    }
+
+    check_pdf2swf();
+
+    my $filename = $argv[0];
+    check_file($filename);
+
+    # print STDERR "Ignore the message called RegOpenKeyEx failed\n";
+
+    my($file_root, $fulldir, $file_ext) = fileparse($filename,qr/\.[^.]*/);
+
+    my $full_folder_name = catfile($ENV{'REALISTIC_BOOKS_HOME'},"books",$file_root);
+
+    copy_model_col($full_folder_name);
+
+    my $html_input = generate_html($full_folder_name,$file_root,$filename);
+
+    # Write out HTML file
+    my $html_file = catfile($full_folder_name,"pages.htm");
+    open (PROD, ">$html_file") || die("Error Writing to File: $html_file $!");
+    print STDERR "Creating $html_file\n";
+
+    print PROD $html_input;
+    close (PROD) || die("Error Closing File: $html_file $!");
+
+
+    print STDOUT "Realistic book generated in $full_folder_name\n";
+
+}
+
+
+&main(scalar(@ARGV),@ARGV);
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/c2ph.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/c2ph.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/c2ph.bat	(revision 19631)
@@ -0,0 +1,1383 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if $running_under_some_shell;
+#
+#
+#   c2ph (aka pstruct)
+#   Tom Christiansen, <tchrist@convex.com>
+#
+#   As pstruct, dump C structures as generated from 'cc -g -S' stabs.
+#   As c2ph, do this PLUS generate perl code for getting at the structures.
+#
+#   See the usage message for more.  If this isn't enough, read the code.
+#
+
+=head1 NAME
+
+c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
+
+=head1 SYNOPSIS
+
+    c2ph [-dpnP] [var=val] [files ...]
+
+=head2 OPTIONS
+
+    Options:
+
+    -w	wide; short for: type_width=45 member_width=35 offset_width=8
+    -x	hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+    -n	do not generate perl code  (default when invoked as pstruct)
+    -p	generate perl code         (default when invoked as c2ph)
+    -v	generate perl code, with C decls as comments
+
+    -i	do NOT recompute sizes for intrinsic datatypes
+    -a	dump information on intrinsics also
+
+    -t	trace execution
+    -d	spew reams of debugging output
+
+    -slist  give comma-separated list a structures to dump
+
+=head1 DESCRIPTION
+
+The following is the old c2ph.doc documentation by Tom Christiansen
+<tchrist@perl.com>
+Date: 25 Jul 91 08:10:21 GMT
+
+Once upon a time, I wrote a program called pstruct.  It was a perl
+program that tried to parse out C structures and display their member
+offsets for you.  This was especially useful for people looking at
+binary dumps or poking around the kernel.
+
+Pstruct was not a pretty program.  Neither was it particularly robust.
+The problem, you see, was that the C compiler was much better at parsing
+C than I could ever hope to be.
+
+So I got smart:  I decided to be lazy and let the C compiler parse the C,
+which would spit out debugger stabs for me to read.  These were much
+easier to parse.  It's still not a pretty program, but at least it's more
+robust.
+
+Pstruct takes any .c or .h files, or preferably .s ones, since that's
+the format it is going to massage them into anyway, and spits out
+listings like this:
+
+ struct tty {
+   int                          tty.t_locker                         000      4
+   int                          tty.t_mutex_index                    004      4
+   struct tty *                 tty.t_tp_virt                        008      4
+   struct clist                 tty.t_rawq                           00c     20
+     int                        tty.t_rawq.c_cc                      00c      4
+     int                        tty.t_rawq.c_cmax                    010      4
+     int                        tty.t_rawq.c_cfx                     014      4
+     int                        tty.t_rawq.c_clx                     018      4
+     struct tty *               tty.t_rawq.c_tp_cpu                  01c      4
+     struct tty *               tty.t_rawq.c_tp_iop                  020      4
+     unsigned char *            tty.t_rawq.c_buf_cpu                 024      4
+     unsigned char *            tty.t_rawq.c_buf_iop                 028      4
+   struct clist                 tty.t_canq                           02c     20
+     int                        tty.t_canq.c_cc                      02c      4
+     int                        tty.t_canq.c_cmax                    030      4
+     int                        tty.t_canq.c_cfx                     034      4
+     int                        tty.t_canq.c_clx                     038      4
+     struct tty *               tty.t_canq.c_tp_cpu                  03c      4
+     struct tty *               tty.t_canq.c_tp_iop                  040      4
+     unsigned char *            tty.t_canq.c_buf_cpu                 044      4
+     unsigned char *            tty.t_canq.c_buf_iop                 048      4
+   struct clist                 tty.t_outq                           04c     20
+     int                        tty.t_outq.c_cc                      04c      4
+     int                        tty.t_outq.c_cmax                    050      4
+     int                        tty.t_outq.c_cfx                     054      4
+     int                        tty.t_outq.c_clx                     058      4
+     struct tty *               tty.t_outq.c_tp_cpu                  05c      4
+     struct tty *               tty.t_outq.c_tp_iop                  060      4
+     unsigned char *            tty.t_outq.c_buf_cpu                 064      4
+     unsigned char *            tty.t_outq.c_buf_iop                 068      4
+   (*int)()                     tty.t_oproc_cpu                      06c      4
+   (*int)()                     tty.t_oproc_iop                      070      4
+   (*int)()                     tty.t_stopproc_cpu                   074      4
+   (*int)()                     tty.t_stopproc_iop                   078      4
+   struct thread *              tty.t_rsel                           07c      4
+
+etc.
+
+
+Actually, this was generated by a particular set of options.  You can control
+the formatting of each column, whether you prefer wide or fat, hex or decimal,
+leading zeroes or whatever.
+
+All you need to be able to use this is a C compiler than generates
+BSD/GCC-style stabs.  The B<-g> option on native BSD compilers and GCC
+should get this for you.
+
+To learn more, just type a bogus option, like B<-\?>, and a long usage message
+will be provided.  There are a fair number of possibilities.
+
+If you're only a C programmer, than this is the end of the message for you.
+You can quit right now, and if you care to, save off the source and run it
+when you feel like it.  Or not.
+
+
+
+But if you're a perl programmer, then for you I have something much more
+wondrous than just a structure offset printer.
+
+You see, if you call pstruct by its other incybernation, c2ph, you have a code
+generator that translates C code into perl code!  Well, structure and union
+declarations at least, but that's quite a bit.
+
+Prior to this point, anyone programming in perl who wanted to interact
+with C programs, like the kernel, was forced to guess the layouts of
+the C structures, and then hardwire these into his program.  Of course,
+when you took your wonderfully crafted program to a system where the
+sgtty structure was laid out differently, your program broke.  Which is
+a shame.
+
+We've had Larry's h2ph translator, which helped, but that only works on
+cpp symbols, not real C, which was also very much needed.  What I offer
+you is a symbolic way of getting at all the C structures.  I've couched
+them in terms of packages and functions.  Consider the following program:
+
+    #!/usr/local/bin/perl
+
+    require 'syscall.ph';
+    require 'sys/time.ph';
+    require 'sys/resource.ph';
+
+    $ru = "\0" x &rusage'sizeof();
+
+    syscall(&SYS_getrusage, &RUSAGE_SELF, $ru)      && die "getrusage: $!";
+
+    @ru = unpack($t = &rusage'typedef(), $ru);
+
+    $utime =  $ru[ &rusage'ru_utime + &timeval'tv_sec  ]
+	   + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
+
+    $stime =  $ru[ &rusage'ru_stime + &timeval'tv_sec  ]
+	   + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
+
+    printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
+
+
+As you see, the name of the package is the name of the structure.  Regular
+fields are just their own names.  Plus the following accessor functions are
+provided for your convenience:
+
+    struct	This takes no arguments, and is merely the number of first-level
+		elements in the structure.  You would use this for indexing
+		into arrays of structures, perhaps like this
+
+
+		    $usec = $u[ &user'u_utimer
+				+ (&ITIMER_VIRTUAL * &itimerval'struct)
+				+ &itimerval'it_value
+				+ &timeval'tv_usec
+			      ];
+
+    sizeof   	Returns the bytes in the structure, or the member if
+	     	you pass it an argument, such as
+
+			&rusage'sizeof(&rusage'ru_utime)
+
+    typedef  	This is the perl format definition for passing to pack and
+	     	unpack.  If you ask for the typedef of a nothing, you get
+	     	the whole structure, otherwise you get that of the member
+	     	you ask for.  Padding is taken care of, as is the magic to
+	     	guarantee that a union is unpacked into all its aliases.
+	     	Bitfields are not quite yet supported however.
+
+    offsetof	This function is the byte offset into the array of that
+		member.  You may wish to use this for indexing directly
+		into the packed structure with vec() if you're too lazy
+		to unpack it.
+
+    typeof	Not to be confused with the typedef accessor function, this
+		one returns the C type of that field.  This would allow
+		you to print out a nice structured pretty print of some
+		structure without knoning anything about it beforehand.
+		No args to this one is a noop.  Someday I'll post such
+		a thing to dump out your u structure for you.
+
+
+The way I see this being used is like basically this:
+
+	% h2ph <some_include_file.h  >  /usr/lib/perl/tmp.ph
+	% c2ph  some_include_file.h  >> /usr/lib/perl/tmp.ph
+	% install
+
+It's a little tricker with c2ph because you have to get the includes right.
+I can't know this for your system, but it's not usually too terribly difficult.
+
+The code isn't pretty as I mentioned  -- I never thought it would be a 1000-
+line program when I started, or I might not have begun. :-)  But I would have
+been less cavalier in how the parts of the program communicated with each
+other, etc.  It might also have helped if I didn't have to divine the makeup
+of the stabs on the fly, and then account for micro differences between my
+compiler and gcc.
+
+Anyway, here it is.  Should run on perl v4 or greater.  Maybe less.
+
+
+ --tom
+
+=cut
+
+$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
+
+use File::Temp;
+
+######################################################################
+
+# some handy data definitions.   many of these can be reset later.
+
+$bitorder = 'b';  # ascending; set to B for descending bit fields
+
+%intrinsics =
+%template = (
+    'char', 			'c',
+    'unsigned char', 		'C',
+    'short',			's',
+    'short int',		's',
+    'unsigned short',		'S',
+    'unsigned short int',	'S',
+    'short unsigned int',	'S',
+    'int',			'i',
+    'unsigned int',		'I',
+    'long',			'l',
+    'long int',			'l',
+    'unsigned long',		'L',
+    'unsigned long',		'L',
+    'long unsigned int',	'L',
+    'unsigned long int',	'L',
+    'long long',		'q',
+    'long long int',		'q',
+    'unsigned long long',	'Q',
+    'unsigned long long int',	'Q',
+    'float',			'f',
+    'double',			'd',
+    'pointer',			'p',
+    'null',			'x',
+    'neganull',			'X',
+    'bit',			$bitorder,
+);
+
+&buildscrunchlist;
+delete $intrinsics{'neganull'};
+delete $intrinsics{'bit'};
+delete $intrinsics{'null'};
+
+# use -s to recompute sizes
+%sizeof = (
+    'char', 			'1',
+    'unsigned char', 		'1',
+    'short',			'2',
+    'short int',		'2',
+    'unsigned short',		'2',
+    'unsigned short int',	'2',
+    'short unsigned int',	'2',
+    'int',			'4',
+    'unsigned int',		'4',
+    'long',			'4',
+    'long int',			'4',
+    'unsigned long',		'4',
+    'unsigned long int',	'4',
+    'long unsigned int',	'4',
+    'long long',		'8',
+    'long long int',		'8',
+    'unsigned long long',	'8',
+    'unsigned long long int',	'8',
+    'float',			'4',
+    'double',			'8',
+    'pointer',			'4',
+);
+
+($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
+
+($offset_fmt, $size_fmt) = ('d', 'd');
+
+$indent = 2;
+
+$CC = 'cc';
+$CFLAGS = '-g -S';
+$DEFINES = '';
+
+$perl++ if $0 =~ m#/?c2ph$#;
+
+require 'getopts.pl';
+
+use File::Temp 'tempdir';
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+&Getopts('aixdpvtnws:') || &usage(0);
+
+$opt_d && $debug++;
+$opt_t && $trace++;
+$opt_p && $perl++;
+$opt_v && $verbose++;
+$opt_n && ($perl = 0);
+
+if ($opt_w) {
+    ($type_width, $member_width, $offset_width) = (45, 35, 8);
+}
+if ($opt_x) {
+    ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
+}
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+sub PLUMBER {
+    select(STDERR);
+    print "oops, apperent pager foulup\n";
+    $isatty++;
+    &usage(1);
+}
+
+sub usage {
+    local($oops) = @_;
+    unless (-t STDOUT) {
+	select(STDERR);
+    } elsif (!$oops) {
+	$isatty++;
+	$| = 1;
+	print "hit <RETURN> for further explanation: ";
+	<STDIN>;
+	open (PIPE, "|". ($ENV{PAGER} || 'more'));
+	$SIG{PIPE} = PLUMBER;
+	select(PIPE);
+    }
+
+    print "usage: $0 [-dpnP] [var=val] [files ...]\n";
+
+    exit unless $isatty;
+
+    print <<EOF;
+
+Options:
+
+-w	wide; short for: type_width=45 member_width=35 offset_width=8
+-x	hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+-n  	do not generate perl code  (default when invoked as pstruct)
+-p  	generate perl code         (default when invoked as c2ph)
+-v	generate perl code, with C decls as comments
+
+-i	do NOT recompute sizes for intrinsic datatypes
+-a	dump information on intrinsics also
+
+-t 	trace execution
+-d	spew reams of debugging output
+
+-slist  give comma-separated list a structures to dump
+
+
+Var Name        Default Value    Meaning
+
+EOF
+
+    &defvar('CC', 'which_compiler to call');
+    &defvar('CFLAGS', 'how to generate *.s files with stabs');
+    &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
+
+    print "\n";
+
+    &defvar('type_width', 'width of type field   (column 1)');
+    &defvar('member_width', 'width of member field (column 2)');
+    &defvar('offset_width', 'width of offset field (column 3)');
+    &defvar('size_width', 'width of size field   (column 4)');
+
+    print "\n";
+
+    &defvar('offset_fmt', 'sprintf format type for offset');
+    &defvar('size_fmt', 'sprintf format type for size');
+
+    print "\n";
+
+    &defvar('indent', 'how far to indent each nesting level');
+
+   print <<'EOF';
+
+    If any *.[ch] files are given, these will be catted together into
+    a temporary *.c file and sent through:
+	    $CC $CFLAGS $DEFINES
+    and the resulting *.s groped for stab information.  If no files are
+    supplied, then stdin is read directly with the assumption that it
+    contains stab information.  All other lines will be ignored.  At
+    most one *.s file should be supplied.
+
+EOF
+    close PIPE;
+    exit 1;
+}
+
+sub defvar {
+    local($var, $msg) = @_;
+    printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;
+}
+
+sub safedir {
+    $SAFEDIR = File::Temp::tempdir("c2ph.XXXXXX", TMPDIR => 1, CLEANUP => 1)
+      unless (defined($SAFEDIR));
+}
+
+undef $SAFEDIR;
+
+$recurse = 1;
+
+if (@ARGV) {
+    if (grep(!/\.[csh]$/,@ARGV)) {
+	warn "Only *.[csh] files expected!\n";
+	&usage;
+    }
+    elsif (grep(/\.s$/,@ARGV)) {
+	if (@ARGV > 1) {
+	    warn "Only one *.s file allowed!\n";
+	    &usage;
+	}
+    }
+    elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
+	local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
+	$chdir = "cd $dir && " if $dir;
+	&system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
+	$ARGV[0] =~ s/\.c$/.s/;
+    }
+    else {
+	&safedir;
+	$TMP = "$SAFEDIR/c2ph.$$.c";
+	&system("cat @ARGV > $TMP") && exit 1;
+	&system("cd $SAFEDIR && $CC $CFLAGS $DEFINES $TMP") && exit 1;
+	unlink $TMP;
+	$TMP =~ s/\.c$/.s/;
+	@ARGV = ($TMP);
+    }
+}
+
+if ($opt_s) {
+    for (split(/[\s,]+/, $opt_s)) {
+	$interested{$_}++;
+    }
+}
+
+
+$| = 1 if $debug;
+
+main: {
+
+    if ($trace) {
+	if (-t && !@ARGV) {
+	    print STDERR "reading from your keyboard: ";
+	} else {
+	    print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
+	}
+    }
+
+STAB: while (<>) {
+	if ($trace && !($. % 10)) {
+	    $lineno = $..'';
+	    print STDERR $lineno, "\b" x length($lineno);
+	}
+	next unless /^\s*\.stabs\s+/;
+	$line = $_;
+	s/^\s*\.stabs\s+//;
+	if (s/\\\\"[d,]+$//) {
+	    $saveline .= $line;
+	    $savebar  = $_;
+	    next STAB;
+	}
+	if ($saveline) {
+	    s/^"//;
+	    $_ = $savebar . $_;
+	    $line = $saveline;
+	}
+	&stab;
+	$savebar = $saveline = undef;
+    }
+    print STDERR "$.\n" if $trace;
+    unlink $TMP if $TMP;
+
+    &compute_intrinsics if $perl && !$opt_i;
+
+    print STDERR "resolving types\n" if $trace;
+
+    &resolve_types;
+    &adjust_start_addrs;
+
+    $sum = 2 + $type_width + $member_width;
+    $pmask1 = "%-${type_width}s %-${member_width}s";
+    $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
+
+
+
+    if ($perl) {
+	# resolve template -- should be in stab define order, but even this isn't enough.
+	print STDERR "\nbuilding type templates: " if $trace;
+	for $i (reverse 0..$#type) {
+	    next unless defined($name = $type[$i]);
+	    next unless defined $struct{$name};
+	    ($iname = $name) =~ s/\..*//;
+	    $build_recursed = 0;
+	    &build_template($name) unless defined $template{&psou($name)} ||
+					$opt_s && !$interested{$iname};
+	}
+	print STDERR "\n\n" if $trace;
+    }
+
+    print STDERR "dumping structs: " if $trace;
+
+    local($iam);
+
+
+
+    foreach $name (sort keys %struct) {
+	($iname = $name) =~ s/\..*//;
+	next if $opt_s && !$interested{$iname};
+	print STDERR "$name " if $trace;
+
+	undef @sizeof;
+	undef @typedef;
+	undef @offsetof;
+	undef @indices;
+	undef @typeof;
+	undef @fieldnames;
+
+	$mname = &munge($name);
+
+	$fname = &psou($name);
+
+	print "# " if $perl && $verbose;
+	$pcode = '';
+	print "$fname {\n" if !$perl || $verbose;
+	$template{$fname} = &scrunch($template{$fname}) if $perl;
+	&pstruct($name,$name,0);
+	print "# " if $perl && $verbose;
+	print "}\n" if !$perl || $verbose;
+	print "\n" if $perl && $verbose;
+
+	if ($perl) {
+	    print "$pcode";
+
+	    printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
+
+	    print <<EOF;
+sub ${mname}'typedef {
+    local(\$${mname}'index) = shift;
+    defined \$${mname}'index
+	? \$${mname}'typedef[\$${mname}'index]
+	: \$${mname}'typedef;
+}
+EOF
+
+	    print <<EOF;
+sub ${mname}'sizeof {
+    local(\$${mname}'index) = shift;
+    defined \$${mname}'index
+	? \$${mname}'sizeof[\$${mname}'index]
+	: \$${mname}'sizeof;
+}
+EOF
+
+	    print <<EOF;
+sub ${mname}'offsetof {
+    local(\$${mname}'index) = shift;
+    defined \$${mname}index
+	? \$${mname}'offsetof[\$${mname}'index]
+	: \$${mname}'sizeof;
+}
+EOF
+
+	    print <<EOF;
+sub ${mname}'typeof {
+    local(\$${mname}'index) = shift;
+    defined \$${mname}index
+	? \$${mname}'typeof[\$${mname}'index]
+	: '$name';
+}
+EOF
+
+	    print <<EOF;
+sub ${mname}'fieldnames {
+    \@${mname}'fieldnames;
+}
+EOF
+
+	$iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
+
+	    print <<EOF;
+sub ${mname}'isastruct {
+    '$iam';
+}
+EOF
+
+	    print "\$${mname}'typedef = '" . &scrunch($template{$fname})
+		. "';\n";
+
+	    print "\$${mname}'sizeof = $sizeof{$name};\n\n";
+
+
+	    print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
+
+	    print "\n";
+
+	    print "\@${mname}'typedef[\@${mname}'indices] = (",
+			join("\n\t", '', @typedef), "\n    );\n\n";
+	    print "\@${mname}'sizeof[\@${mname}'indices] = (",
+			join("\n\t", '', @sizeof), "\n    );\n\n";
+	    print "\@${mname}'offsetof[\@${mname}'indices] = (",
+			join("\n\t", '', @offsetof), "\n    );\n\n";
+	    print "\@${mname}'typeof[\@${mname}'indices] = (",
+			join("\n\t", '', @typeof), "\n    );\n\n";
+	    print "\@${mname}'fieldnames[\@${mname}'indices] = (",
+			join("\n\t", '', @fieldnames), "\n    );\n\n";
+
+	    $template_printed{$fname}++;
+	    $size_printed{$fname}++;
+	}
+	print "\n";
+    }
+
+    print STDERR "\n" if $trace;
+
+    unless ($perl && $opt_a) {
+	print "\n1;\n" if $perl;
+	exit;
+    }
+
+
+
+    foreach $name (sort bysizevalue keys %intrinsics) {
+	next if $size_printed{$name};
+	print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
+    }
+
+    print "\n";
+
+    sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
+
+
+    foreach $name (sort keys %intrinsics) {
+	print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
+    }
+
+    print "\n1;\n" if $perl;
+
+    exit;
+}
+
+########################################################################################
+
+
+sub stab {
+    next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/;  # (\d+,\d+) is for sun
+    s/"// 						|| next;
+    s/",([x\d]+),([x\d]+),([x\d]+),.*// 		|| next;
+
+    next if /^\s*$/;
+
+    $size = $3 if $3;
+    $_ = $continued . $_ if length($continued);
+    if (s/\\\\$//) {
+      # if last 2 chars of string are '\\' then stab is continued
+      # in next stab entry
+      chop;
+      $continued = $_;
+      next;
+    }
+    $continued = '';
+
+
+    $line = $_;
+
+    if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
+	print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
+	&pdecl($pdecl);
+	next;
+    }
+
+
+
+    if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
+	local($ident) = $2;
+	push(@intrinsics, $ident);
+	$typeno = &typeno($3);
+	$type[$typeno] = $ident;
+	print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
+	next;
+    }
+
+    if (($name, $typeordef, $typeno, $extra, $struct, $_)
+	= /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
+    {
+	$typeno = &typeno($typeno);  # sun foolery
+    }
+    elsif (/^[\$\w]+:/) {
+	next; # variable
+    }
+    else {
+	warn "can't grok stab: <$_> in: $line " if $_;
+	next;
+    }
+
+    #warn "got size $size for $name\n";
+    $sizeof{$name} = $size if $size;
+
+    s/;[-\d]*;[-\d]*;$//;  # we don't care about ranges
+
+    $typenos{$name} = $typeno;
+
+    unless (defined $type[$typeno]) {
+	&panic("type 0??") unless $typeno;
+	$type[$typeno] = $name unless defined $type[$typeno];
+	printf "new type $typeno is $name" if $debug;
+	if ($extra =~ /\*/ && defined $type[$struct]) {
+	    print ", a typedef for a pointer to " , $type[$struct] if $debug;
+	}
+    } else {
+	printf "%s is type %d", $name, $typeno if $debug;
+	print ", a typedef for " , $type[$typeno] if $debug;
+    }
+    print "\n" if $debug;
+    #next unless $extra =~ /[su*]/;
+
+    #$type[$struct] = $name;
+
+    if ($extra =~ /[us*]/) {
+	&sou($name, $extra);
+	$_ = &sdecl($name, $_, 0);
+    }
+    elsif (/^=ar/) {
+	print "it's a bare array typedef -- that's pretty sick\n" if $debug;
+	$_ = "$typeno$_";
+	$scripts = '';
+	$_ = &adecl($_,1);
+
+    }
+    elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) {  # the ?'s are for gcc
+	push(@intrinsics, $2);
+	$typeno = &typeno($3);
+	$type[$typeno] = $2;
+	print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
+    }
+    elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
+	&edecl;
+    }
+    else {
+	warn "Funny remainder for $name on line $_ left in $line " if $_;
+    }
+}
+
+sub typeno {  # sun thinks types are (0,27) instead of just 27
+    local($_) = @_;
+    s/\(\d+,(\d+)\)/$1/;
+    $_;
+}
+
+sub pstruct {
+    local($what,$prefix,$base) = @_;
+    local($field, $fieldname, $typeno, $count, $offset, $entry);
+    local($fieldtype);
+    local($type, $tname);
+    local($mytype, $mycount, $entry2);
+    local($struct_count) = 0;
+    local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
+    local($bits,$bytes);
+    local($template);
+
+
+    local($mname) = &munge($name);
+
+    sub munge {
+	local($_) = @_;
+	s/[\s\$\.]/_/g;
+	$_;
+    }
+
+    local($sname) = &psou($what);
+
+    $nesting++;
+
+    for $field (split(/;/, $struct{$what})) {
+	$pad = $prepad = 0;
+	$entry = '';
+	($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
+
+	$type = $type[$typeno];
+
+	$type =~ /([^[]*)(\[.*\])?/;
+	$mytype = $1;
+	$count .= $2;
+	$fieldtype = &psou($mytype);
+
+	local($fname) = &psou($name);
+
+	if ($build_templates) {
+
+	    $pad = ($offset - ($lastoffset + $lastlength))/8
+		if defined $lastoffset;
+
+	    if (! $finished_template{$sname}) {
+		if ($isaunion{$what}) {
+		    $template{$sname} .= 'X' x $revpad . ' '    if $revpad;
+		} else {
+		    $template{$sname} .= 'x' x $pad    . ' '    if $pad;
+		}
+	    }
+
+	    $template = &fetch_template($type);
+	    &repeat_template($template,$count);
+
+	    if (! $finished_template{$sname}) {
+		$template{$sname} .= $template;
+	    }
+
+	    $revpad = $length/8 if $isaunion{$what};
+
+	    ($lastoffset, $lastlength) = ($offset, $length);
+
+	} else {
+	    print '# ' if $perl && $verbose;
+	    $entry = sprintf($pmask1,
+			' ' x ($nesting * $indent) . $fieldtype,
+			"$prefix.$fieldname" . $count);
+
+	    $entry =~ s/(\*+)( )/$2$1/;
+
+	    printf $pmask2,
+		    $entry,
+		    ($base+$offset)/8,
+		    ($bits = ($base+$offset)%8) ? ".$bits" : "  ",
+		    $length/8,
+		    ($bits = $length % 8) ? ".$bits": ""
+			if !$perl || $verbose;
+
+	    if ($perl) {
+		$template = &fetch_template($type);
+		&repeat_template($template,$count);
+	    }
+
+	    if ($perl && $nesting == 1) {
+
+		push(@sizeof, int($length/8) .",\t# $fieldname");
+		push(@offsetof, int($offset/8) .",\t# $fieldname");
+		local($little) = &scrunch($template);
+		push(@typedef, "'$little', \t# $fieldname");
+		$type =~ s/(struct|union) //;
+		push(@typeof, "'$mytype" . ($count ? $count : '') .
+		    "',\t# $fieldname");
+		push(@fieldnames, "'$fieldname',");
+	    }
+
+	    print '  ', ' ' x $indent x $nesting, $template
+				if $perl && $verbose;
+
+	    print "\n" if !$perl || $verbose;
+
+	}
+	if ($perl) {
+	    local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
+	    $mycount *= &scripts2count($count) if $count;
+	    if ($nesting==1 && !$build_templates) {
+		$pcode .= sprintf("sub %-32s { %4d; }\n",
+			"${mname}'${fieldname}", $struct_count);
+		push(@indices, $struct_count);
+	    }
+	    $struct_count += $mycount;
+	}
+
+
+	&pstruct($type, "$prefix.$fieldname", $base+$offset)
+		if $recurse && defined $struct{$type};
+    }
+
+    $countof{$what} = $struct_count unless defined $countof{$whati};
+
+    $template{$sname} .= '$' if $build_templates;
+    $finished_template{$sname}++;
+
+    if ($build_templates && !defined $sizeof{$name}) {
+	local($fmt) = &scrunch($template{$sname});
+	print STDERR "no size for $name, punting with $fmt..." if $debug;
+	eval '$sizeof{$name} = length(pack($fmt, ()))';
+	if ($@) {
+	    chop $@;
+	    warn "couldn't get size for \$name: $@";
+	} else {
+	    print STDERR $sizeof{$name}, "\n" if $debUg;
+	}
+    }
+
+    --$nesting;
+}
+
+
+sub psize {
+    local($me) = @_;
+    local($amstruct) = $struct{$me} ?  'struct ' : '';
+
+    print '$sizeof{\'', $amstruct, $me, '\'} = ';
+    printf "%d;\n", $sizeof{$me};
+}
+
+sub pdecl {
+    local($pdecl) = @_;
+    local(@pdecls);
+    local($tname);
+
+    warn "pdecl: $pdecl\n" if $debug;
+
+    $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
+    $pdecl =~ s/\*//g;
+    @pdecls = split(/=/, $pdecl);
+    $typeno = $pdecls[0];
+    $tname = pop @pdecls;
+
+    if ($tname =~ s/^f//) { $tname = "$tname&"; }
+    #else { $tname = "$tname*"; }
+
+    for (reverse @pdecls) {
+	$tname  .= s/^f// ? "&" : "*";
+	#$tname =~ s/^f(.*)/$1&/;
+	print "type[$_] is $tname\n" if $debug;
+	$type[$_] = $tname unless defined $type[$_];
+    }
+}
+
+
+
+sub adecl {
+    ($arraytype, $unknown, $lower, $upper) = ();
+    #local($typeno);
+    # global $typeno, @type
+    local($_, $typedef) = @_;
+
+    while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
+	($arraytype, $unknown) = ($2, $3);
+	$arraytype = &typeno($arraytype);
+	$unknown = &typeno($unknown);
+	if (s/^(\d+);(\d+);//) {
+	    ($lower, $upper) = ($1, $2);
+	    $scripts .= '[' .  ($upper+1) . ']';
+	} else {
+	    warn "can't find array bounds: $_";
+	}
+    }
+    if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
+	($start, $length) = ($2, $3);
+	$whatis = $1;
+	if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
+	    $typeno = &typeno($1);
+	    &pdecl($whatis);
+	} else {
+	    $typeno = &typeno($whatis);
+	}
+    } elsif (s/^(\d+)(=[*suf]\d*)//) {
+	local($whatis) = $2;
+
+	if ($whatis =~ /[f*]/) {
+	    &pdecl($whatis);
+	} elsif ($whatis =~ /[su]/) {  #
+	    print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
+		if $debug;
+	    #$type[$typeno] = $name unless defined $type[$typeno];
+	    ##printf "new type $typeno is $name" if $debug;
+	    $typeno = $1;
+	    $type[$typeno] = "$prefix.$fieldname";
+	    local($name) = $type[$typeno];
+	    &sou($name, $whatis);
+	    $_ = &sdecl($name, $_, $start+$offset);
+	    1;
+	    $start = $start{$name};
+	    $offset = $sizeof{$name};
+	    $length = $offset;
+	} else {
+	    warn "what's this? $whatis in $line ";
+	}
+    } elsif (/^\d+$/) {
+	$typeno = $_;
+    } else {
+	warn "bad array stab: $_ in $line ";
+	next STAB;
+    }
+    #local($wasdef) = defined($type[$typeno]) && $debug;
+    #if ($typedef) {
+	#print "redefining $type[$typeno] to " if $wasdef;
+	#$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
+	#print "$type[$typeno]\n" if $wasdef;
+    #} else {
+	#$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
+    #}
+    $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
+    print "type[$arraytype] is $type[$arraytype]\n" if $debug;
+    print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
+    $_;
+}
+
+
+
+sub sdecl {
+    local($prefix, $_, $offset) = @_;
+
+    local($fieldname, $scripts, $type, $arraytype, $unknown,
+    $whatis, $pdecl, $upper,$lower, $start,$length) = ();
+    local($typeno,$sou);
+
+
+SFIELD:
+    while (/^([^;]+);/) {
+	$scripts = '';
+	warn "sdecl $_\n" if $debug;
+	if (s/^([\$\w]+)://) {
+	    $fieldname = $1;
+	} elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
+	    $typeno = &typeno($1);
+	    $type[$typeno] = "$prefix.$fieldname";
+	    local($name) = "$prefix.$fieldname";
+	    &sou($name,$2);
+	    $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+	    $start = $start{$name};
+	    $offset += $sizeof{$name};
+	    #print "done with anon, start is $start, offset is $offset\n";
+	    #next SFIELD;
+	} else  {
+	    warn "weird field $_ of $line" if $debug;
+	    next STAB;
+	    #$fieldname = &gensym;
+	    #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+	}
+
+	if (/^(\d+|\(\d+,\d+\))=ar/) {
+	    $_ = &adecl($_);
+	}
+	elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
+          ($start, $length) =  ($2, $3);
+          &panic("no length?") unless $length;
+          $typeno = &typeno($1) if $1;
+        }
+        elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
+	    ($start, $length) =  ($2, $3);
+	    &panic("no length?") unless $length;
+	    $typeno = &typeno($1) if $1;
+	}
+	elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
+	    ($pdecl, $start, $length) =  ($1,$5,$6);
+	    &pdecl($pdecl);
+	}
+	elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
+	    ($typeno, $sou) = ($1, $2);
+	    $typeno = &typeno($typeno);
+	    if (defined($type[$typeno])) {
+		warn "now how did we get type $1 in $fieldname of $line?";
+	    } else {
+		print "anon type $typeno is $prefix.$fieldname\n" if $debug;
+		$type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
+	    };
+	    local($name) = "$prefix.$fieldname";
+	    &sou($name,$sou);
+	    print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
+	    $type[$typeno] = "$prefix.$fieldname";
+	    $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+	    $start = $start{$name};
+	    $length = $sizeof{$name};
+	}
+	else {
+	    warn "can't grok stab for $name ($_) in line $line ";
+	    next STAB;
+	}
+
+	&panic("no length for $prefix.$fieldname") unless $length;
+	$struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
+    }
+    if (s/;\d*,(\d+),(\d+);//) {
+	local($start, $size) = ($1, $2);
+	$sizeof{$prefix} = $size;
+	print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
+	$start{$prefix} = $start;
+    }
+    $_;
+}
+
+sub edecl {
+    s/;$//;
+    $enum{$name} = $_;
+    $_ = '';
+}
+
+sub resolve_types {
+    local($sou);
+    for $i (0 .. $#type) {
+	next unless defined $type[$i];
+	$_ = $type[$i];
+	unless (/\d/) {
+	    print "type[$i] $type[$i]\n" if $debug;
+	    next;
+	}
+	print "type[$i] $_ ==> " if $debug;
+	s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
+	s/^(\d+)\&/&type($1)/e;
+	s/^(\d+)/&type($1)/e;
+	s/(\*+)([^*]+)(\*+)/$1$3$2/;
+	s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
+	s/^(\d+)([\*\[].*)/&type($1).$2/e;
+	#s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
+	$type[$i] = $_;
+	print "$_\n" if $debug;
+    }
+}
+sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
+
+sub adjust_start_addrs {
+    for (sort keys %start) {
+	($basename = $_) =~ s/\.[^.]+$//;
+	$start{$_} += $start{$basename};
+	print "start: $_ @ $start{$_}\n" if $debug;
+    }
+}
+
+sub sou {
+    local($what, $_) = @_;
+    /u/ && $isaunion{$what}++;
+    /s/ && $isastruct{$what}++;
+}
+
+sub psou {
+    local($what) = @_;
+    local($prefix) = '';
+    if ($isaunion{$what})  {
+	$prefix = 'union ';
+    } elsif ($isastruct{$what})  {
+	$prefix = 'struct ';
+    }
+    $prefix . $what;
+}
+
+sub scrunch {
+    local($_) = @_;
+
+    return '' if $_ eq '';
+
+    study;
+
+    s/\$//g;
+    s/  / /g;
+    1 while s/(\w) \1/$1$1/g;
+
+    # i wanna say this, but perl resists my efforts:
+    #	   s/(\w)(\1+)/$2 . length($1)/ge;
+
+    &quick_scrunch;
+
+    s/ $//;
+
+    $_;
+}
+
+sub buildscrunchlist {
+    $scrunch_code = "sub quick_scrunch {\n";
+    for (values %intrinsics) {
+        $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
+    }
+    $scrunch_code .= "}\n";
+    print "$scrunch_code" if $debug;
+    eval $scrunch_code;
+    &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
+}
+
+sub fetch_template {
+    local($mytype) = @_;
+    local($fmt);
+    local($count) = 1;
+
+    &panic("why do you care?") unless $perl;
+
+    if ($mytype =~ s/(\[\d+\])+$//) {
+	$count .= $1;
+    }
+
+    if ($mytype =~ /\*/) {
+	$fmt = $template{'pointer'};
+    }
+    elsif (defined $template{$mytype}) {
+	$fmt = $template{$mytype};
+    }
+    elsif (defined $struct{$mytype}) {
+	if (!defined $template{&psou($mytype)}) {
+	    &build_template($mytype) unless $mytype eq $name;
+	}
+	elsif ($template{&psou($mytype)} !~ /\$$/) {
+	    #warn "incomplete template for $mytype\n";
+	}
+	$fmt = $template{&psou($mytype)} || '?';
+    }
+    else {
+	warn "unknown fmt for $mytype\n";
+	$fmt = '?';
+    }
+
+    $fmt x $count . ' ';
+}
+
+sub compute_intrinsics {
+    &safedir;
+    local($TMP) = "$SAFEDIR/c2ph-i.$$.c";
+    open (TMP, ">$TMP") || die "can't open $TMP: $!";
+    select(TMP);
+
+    print STDERR "computing intrinsic sizes: " if $trace;
+
+    undef %intrinsics;
+
+    print <<'EOF';
+main() {
+    char *mask = "%d %s\n";
+EOF
+
+    for $type (@intrinsics) {
+	next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
+	print <<"EOF";
+    printf(mask,sizeof($type), "$type");
+EOF
+    }
+
+    print <<'EOF';
+    printf(mask,sizeof(char *), "pointer");
+    exit(0);
+}
+EOF
+    close TMP;
+
+    select(STDOUT);
+    open(PIPE, "cd $SAFEDIR && $CC $TMP && $SAFEDIR/a.out|");
+    while (<PIPE>) {
+	chop;
+	split(' ',$_,2);;
+	print "intrinsic $_[1] is size $_[0]\n" if $debug;
+	$sizeof{$_[1]} = $_[0];
+	$intrinsics{$_[1]} = $template{$_[0]};
+    }
+    close(PIPE) || die "couldn't read intrinsics!";
+    unlink($TMP, '$SAFEDIR/a.out');
+    print STDERR "done\n" if $trace;
+}
+
+sub scripts2count {
+    local($_) = @_;
+
+    s/^\[//;
+    s/\]$//;
+    s/\]\[/*/g;
+    $_ = eval;
+    &panic("$_: $@") if $@;
+    $_;
+}
+
+sub system {
+    print STDERR "@_\n" if $trace;
+    system @_;
+}
+
+sub build_template {
+    local($name) = @_;
+
+    &panic("already got a template for $name") if defined $template{$name};
+
+    local($build_templates) = 1;
+
+    local($lparen) = '(' x $build_recursed;
+    local($rparen) = ')' x $build_recursed;
+
+    print STDERR "$lparen$name$rparen " if $trace;
+    $build_recursed++;
+    &pstruct($name,$name,0);
+    print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
+    --$build_recursed;
+}
+
+
+sub panic {
+
+    select(STDERR);
+
+    print "\npanic: @_\n";
+
+    exit 1 if $] <= 4.003;  # caller broken
+
+    local($i,$_);
+    local($p,$f,$l,$s,$h,$a,@a,@sub);
+    for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+	@a = @DB'args;
+	for (@a) {
+	    if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+		$_ = sprintf("%s",$_);
+	    }
+	    else {
+		s/'/\\'/g;
+		s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+		s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+		s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+	    }
+	}
+	$w = $w ? '@ = ' : '$ = ';
+	$a = $h ? '(' . join(', ', @a) . ')' : '';
+	push(@sub, "$w&$s$a from file $f line $l\n");
+	last if $signal;
+    }
+    for ($i=0; $i <= $#sub; $i++) {
+	last if $signal;
+	print $sub[$i];
+    }
+    exit 1;
+}
+
+sub squishseq {
+    local($num);
+    local($last) = -1e8;
+    local($string);
+    local($seq) = '..';
+
+    while (defined($num = shift)) {
+        if ($num == ($last + 1)) {
+            $string .= $seq unless $inseq++;
+            $last = $num;
+            next;
+        } elsif ($inseq) {
+            $string .= $last unless $last == -1e8;
+        }
+
+        $string .= ',' if defined $string;
+        $string .= $num;
+        $last = $num;
+        $inseq = 0;
+    }
+    $string .= $last if $inseq && $last != -e18;
+    $string;
+}
+
+sub repeat_template {
+    #  local($template, $scripts) = @_;  have to change caller's values
+
+    if ( $_[1] ) {
+	local($ncount) = &scripts2count($_[1]);
+	if ($_[0] =~ /^\s*c\s*$/i) {
+	    $_[0] = "A$ncount ";
+	    $_[1] = '';
+	} else {
+	    $_[0] = $template x $ncount;
+	}
+    }
+}
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/cpan.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/cpan.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/cpan.bat	(revision 19631)
@@ -0,0 +1,222 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if $running_under_some_shell;
+#!/usr/bin/perl
+# $Id: cpan,v 1.3 2002/08/30 08:55:15 k Exp $
+use strict;
+
+=head1 NAME
+
+cpan - easily interact with CPAN from the command line
+
+=head1 SYNOPSIS
+
+	# with arguments, installs specified modules
+	cpan module_name [ module_name ... ]
+	
+	# with switches, installs modules with extra behavior
+	cpan [-cimt] module_name [ module_name ... ]
+	
+	# without arguments, starts CPAN shell
+	cpan
+	
+	# without arguments, but some switches
+	cpan [-ahrv]
+
+=head1 DESCRIPTION
+
+This script provides a command interface (not a shell) to CPAN.pm.
+
+=head2 Meta Options
+
+These options are mutually exclusive, and the script processes
+them in this order: [ahvr].  Once the script finds one, it ignores
+the others, and then exits after it finishes the task.  The script
+ignores any other command line options.
+
+=over 4
+
+=item -a
+
+Creates the CPAN.pm autobundle with CPAN::Shell->autobundle.  
+
+=item -h
+
+Prints a help message.
+
+=item -r
+
+Recompiles dynamically loaded modules with CPAN::Shell->recompile.
+
+=item -v
+
+Print the script version and CPAN.pm version.
+
+=back
+
+=head2 Module options
+
+These options are mutually exclusive, and the script processes
+them in alphabetical order. 
+
+=over 4
+
+=item c
+
+Runs a `make clean` in the specified module's directories.
+
+=item i
+
+Installed the specified modules.
+
+=item m
+
+Makes the specified modules.
+
+=item t
+
+Runs a `make test` on the specified modules.
+
+=back
+
+=head2 Examples
+
+	# print a help message
+	cpan -h
+	
+	# print the version numbers
+	cpan -v
+	
+	# create an autobundle
+	cpan -a
+	
+	# recompile modules
+	cpan -r 
+	
+	# install modules
+	cpan -i Netscape::Booksmarks Business::ISBN
+
+=head1 TO DO
+
+* add options for other CPAN::Shell functions
+autobundle, clean, make, recompile, test
+
+=head1 BUGS
+
+* none noted
+
+=head1 SEE ALSO
+
+Most behaviour, including environment variables and configuration,
+comes directly from CPAN.pm.
+
+=head1 AUTHOR
+
+brian d foy <bdfoy@cpan.org>
+
+=cut
+
+use CPAN ();
+use Getopt::Std;
+
+my $VERSION = 
+	sprintf "%d.%02d", q$Revision: 1.3 $ =~ m/ (\d+) \. (\d+) /xg;
+
+my $Default = 'default';
+
+my $META_OPTIONS = 'ahvr';
+
+my %CPAN_METHODS = (
+	$Default => 'install',
+	'c'      => 'clean',
+	'i'      => 'install',
+	'm'      => 'make',
+	't'      => 'test',
+	);
+
+my @cpan_options = grep { $_ ne $Default } sort keys %CPAN_METHODS;
+
+my $arg_count = @ARGV;
+my %options;
+
+Getopt::Std::getopts( 
+	join( '', @cpan_options, $META_OPTIONS ), \%options );
+	
+if( $options{h} )
+	{
+	print STDERR "Printing help message -- ignoring other arguments\n"
+		if $arg_count > 1;
+
+	print STDERR "Use perldoc to read the documentation\n";
+	exit 0;
+	}
+elsif( $options{v} )
+	{
+	print STDERR "Printing version message -- ignoring other arguments\n"
+	
+		if $arg_count > 1;
+
+	my $CPAN_VERSION = CPAN->VERSION;
+	print STDERR "cpan script version $VERSION\n" .
+		"CPAN.pm version $CPAN_VERSION\n";
+	exit 0;
+	}
+elsif( $options{a} )
+	{
+	print "Creating autobundle in ", $CPAN::Config->{cpan_home}, 
+		"/Bundle\n";
+	print STDERR "Creating autobundle -- ignoring other arguments\n"
+		if $arg_count > 1;
+
+	CPAN::Shell->autobundle;
+	exit 0;
+	}
+elsif( $options{r} )
+	{
+	print STDERR "Creating autobundle -- ignoring other arguments\n"
+		if $arg_count > 1;
+		
+	CPAN::Shell->recompile;
+	}
+else
+	{
+	my $switch = '';
+	
+	foreach my $option ( @cpan_options )
+		{
+		next unless $options{$option};
+		$switch = $option;
+		last;
+		}
+	
+	   if( not $switch and     @ARGV ) { $switch = $Default;     }
+	elsif( not $switch and not @ARGV ) { CPAN::shell(); exit 0;  }	
+	elsif(     $switch and not @ARGV ) 
+		{ die "Nothing to $CPAN_METHODS{$switch}!\n"; }
+
+	my $method = $CPAN_METHODS{$switch};
+	die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method );
+	
+	foreach my $arg ( @ARGV )
+		{
+		CPAN::Shell->$method( $arg );
+		}
+	}
+	
+1;
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/dprofpp.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/dprofpp.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/dprofpp.bat	(revision 19631)
@@ -0,0 +1,945 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec perl -S $0 "$@"'
+	if 0;
+
+require 5.003;
+
+my $VERSION = '20050603.00';
+my $stty    = undef;
+
+=head1 NAME
+
+dprofpp - display perl profile data
+
+=head1 SYNOPSIS
+
+dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-d>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
+  
+dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-G> <regexp> [B<-P>] [profile]
+ 
+dprofpp B<-p script> [B<-Q>] [other opts]
+
+dprofpp B<-V> [profile]
+
+=head1 DESCRIPTION
+
+The I<dprofpp> command interprets profile data produced by a profiler, such
+as the Devel::DProf profiler.  Dprofpp will read the file F<tmon.out> and
+display the 15 subroutines which are using the most time.  By default
+the times for each subroutine are given exclusive of the times of their
+child subroutines.
+
+To profile a Perl script run the perl interpreter with the B<-d> switch.  So
+to profile script F<test.pl> with Devel::DProf use the following:
+
+	$ perl5 -d:DProf test.pl
+
+Then run dprofpp to analyze the profile.  The output of dprofpp depends
+on the flags to the program and the version of Perl you're using.
+
+	$ dprofpp -u
+	Total Elapsed Time =    1.67 Seconds
+		 User Time =    0.61 Seconds
+	Exclusive Times
+	%Time Seconds     #Calls sec/call Name
+	 52.4   0.320          2   0.1600 main::foo
+	 45.9   0.280        200   0.0014 main::bar
+	 0.00   0.000          1   0.0000 DynaLoader::import
+	 0.00   0.000          1   0.0000 main::baz
+
+The dprofpp tool can also run the profiler before analyzing the profile
+data.  The above two commands can be executed with one dprofpp command.
+
+	$ dprofpp -u -p test.pl
+
+Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
+
+=head1 OUTPUT
+
+Columns are:
+
+=over 4
+
+=item %Time
+
+Percentage of time spent in this routine.
+
+=item #Calls
+
+Number of calls to this routine.
+
+=item sec/call
+
+Average number of seconds per call to this routine.
+
+=item Name
+
+Name of routine.
+
+=item CumulS
+
+Time (in seconds) spent in this routine and routines called from it.
+
+=item ExclSec
+
+Time (in seconds) spent in this routine (not including those called
+from it).
+
+=item Csec/c
+
+Average time (in seconds) spent in each call of this routine
+(including those called from it).
+
+=back
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-a>
+
+Sort alphabetically by subroutine names.
+
+=item B<-d>
+
+Reverse whatever sort is used
+
+=item B<-A>
+
+Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
+Otherwise the time to autoload it is counted as time of the subroutine
+itself (there is no way to separate autoload time from run time).
+
+This is going to be irrelevant with newer Perls.  They will inform
+C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
+so a separate statistics for C<AUTOLOAD> will be collected no matter
+whether this option is set.
+
+=item B<-R>
+
+Count anonymous subroutines defined in the same package separately.
+
+=item B<-E>
+
+(default)  Display all subroutine times exclusive of child subroutine times.
+
+=item B<-F>
+
+Force the generation of fake exit timestamps if dprofpp reports that the
+profile is garbled.  This is only useful if dprofpp determines that the
+profile is garbled due to missing exit timestamps.  You're on your own if
+you do this.  Consult the BUGS section.
+
+=item B<-I>
+
+Display all subroutine times inclusive of child subroutine times.
+
+=item B<-l>
+
+Sort by number of calls to the subroutines.  This may help identify
+candidates for inlining.
+
+=item B<-O cnt>
+
+Show only I<cnt> subroutines.  The default is 15.
+
+=item B<-p script>
+
+Tells dprofpp that it should profile the given script and then interpret its
+profile data.  See B<-Q>.
+
+=item B<-Q>
+
+Used with B<-p> to tell dprofpp to quit after profiling the script, without
+interpreting the data.
+
+=item B<-q>
+
+Do not display column headers.
+
+=item B<-r>
+
+Display elapsed real times rather than user+system times.
+
+=item B<-s>
+
+Display system times rather than user+system times.
+
+=item B<-T>
+
+Display subroutine call tree to stdout.  Subroutine statistics are
+not displayed.
+
+=item B<-t>
+
+Display subroutine call tree to stdout.  Subroutine statistics are not
+displayed.  When a function is called multiple consecutive times at the same
+calling level then it is displayed once with a repeat count.
+
+=item B<-S>
+
+Display I<merged> subroutine call tree to stdout.  Statistics are
+displayed for each branch of the tree.  
+
+When a function is called multiple (I<not necessarily consecutive>)
+times in the same branch then all these calls go into one branch of
+the next level.  A repeat count is output together with combined
+inclusive, exclusive and kids time.
+
+Branches are sorted with regard to inclusive time.
+
+=item B<-U>
+
+Do not sort.  Display in the order found in the raw profile.
+
+=item B<-u>
+
+Display user times rather than user+system times.
+
+=item B<-V>
+
+Print dprofpp's version number and exit.  If a raw profile is found then its
+XS_VERSION variable will be displayed, too.
+
+=item B<-v>
+
+Sort by average time spent in subroutines during each call.  This may help
+identify candidates for inlining. 
+
+=item B<-z>
+
+(default) Sort by amount of user+system time used.  The first few lines
+should show you which subroutines are using the most time.
+
+=item B<-g> C<subroutine>
+
+Ignore subroutines except C<subroutine> and whatever is called from it.
+
+=item B<-G> <regexp>
+
+Aggregate "Group" all calls matching the pattern together.
+For example this can be used to group all calls of a set of packages
+
+  -G "(package1::)|(package2::)|(package3::)"
+
+or to group subroutines by name:
+
+  -G "getNum"
+
+=item B<-P>
+
+Used with -G to aggregate "Pull" together all calls that did not match -G.
+
+=item B<-f> <regexp>
+
+Filter all calls matching the pattern.
+
+=item B<-h>
+
+Display brief help and exit.
+
+=item B<-H>
+
+Display long help and exit.
+
+=back
+
+=head1 ENVIRONMENT
+
+The environment variable B<DPROFPP_OPTS> can be set to a string containing
+options for dprofpp.  You might use this if you prefer B<-I> over B<-E> or
+if you want B<-F> on all the time.
+
+This was added fairly lazily, so there are some undesirable side effects.
+Options on the commandline should override options in DPROFPP_OPTS--but
+don't count on that in this version.
+
+=head1 BUGS
+
+Applications which call _exit() or exec() from within a subroutine
+will leave an incomplete profile.  See the B<-F> option.
+
+Any bugs in Devel::DProf, or any profiler generating the profile data, could
+be visible here.  See L<Devel::DProf/BUGS>.
+
+Mail bug reports and feature requests to the perl5-porters mailing list at
+F<E<lt>perl5-porters@perl.orgE<gt>>.  Bug reports should include the
+output of the B<-V> option.
+
+=head1 FILES
+
+	dprofpp		- profile processor
+	tmon.out	- raw profile
+
+=head1 SEE ALSO
+
+L<perl>, L<Devel::DProf>, times(2)
+
+=cut
+
+sub shortusage {
+    print <<'EOF';
+dprofpp [options] [profile]
+
+    -A          Count autoloaded to *AUTOLOAD
+    -a          Sort by alphabetic name of subroutines.
+    -d          Reverse sort
+    -E          Sub times are reported exclusive of child times. (default)
+    -f          Filter all calls mathcing the pattern.
+    -G          Group all calls matching the pattern together.
+    -g subr     Count only those who are SUBR or called from SUBR
+    -H          Display long manual page.
+    -h          Display this short usage message.
+    -I          Sub times are reported inclusive of child times.
+    -l          Sort by number of calls to subroutines.
+    -O cnt      Specifies maximum number of subroutines to display.
+    -P          Used with -G to pull all other calls together.
+    -p script   Specifies name of script to be profiled.
+    -Q          Used with -p to indicate the dprofpp should quit
+                after profiling the script, without interpreting the data.
+    -q          Do not print column headers.
+    -R          Count anonyms separately even if from the same package
+    -r          Use real elapsed time rather than user+system time.
+    -S          Create statistics for all the depths
+    -s          Use system time rather than user+system time.
+    -T          Show call tree.
+    -t          Show call tree, compressed.
+    -U          Do not sort subroutines.
+    -u          Use user time rather than user+system time.
+    -V          Print dprofpp's version.
+    -v          Sort by average amount of time spent in subroutines.
+    -z          Sort by user+system time spent in subroutines. (default)
+EOF
+}
+
+use Getopt::Std 'getopts';
+use Config '%Config';
+
+Setup: {
+	my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
+
+	$Monfile = 'tmon.out';
+	if( exists $ENV{DPROFPP_OPTS} ){
+		my @tmpargv = @ARGV;
+		@ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
+		getopts( $options );
+		if( @ARGV ){
+			# there was a filename.
+			$Monfile = shift;
+		}
+		@ARGV = @tmpargv;
+	}
+
+	getopts( $options ) or die "Try 'dprofpp -h' for help.\n";
+	if( @ARGV ){
+		# there was a filename, it overrides any earlier name.
+		$Monfile = shift;
+	}
+
+        if ( defined $opt_h ) {
+                shortusage();
+                exit;
+        }
+        if ( defined $opt_H ) {
+                require Pod::Usage;
+                Pod::Usage::pod2usage( {-verbose => 2, -input => $0 } );
+                exit;
+        }
+
+	if( defined $opt_V ){
+		my $fh = 'main::fh';
+		print "$0 version: $VERSION\n";
+		open( $fh, "<$Monfile" ) && do {
+			local $XS_VERSION = 'early';
+			header($fh);
+			close( $fh );
+			print "XS_VERSION: $XS_VERSION\n";
+		};
+		exit(0);
+	}
+	$cnt = $opt_O || 15;
+	$sort = 'by_time';
+	$sort = 'by_ctime' if defined $opt_I;
+	$sort = 'by_calls' if defined $opt_l;
+	$sort = 'by_alpha' if defined $opt_a;
+	$sort = 'by_avgcpu' if defined $opt_v;
+	
+	if(defined $opt_d){
+		$sort = "r".$sort;
+	}
+	$incl_excl = 'Exclusive';
+	$incl_excl = 'Inclusive' if defined $opt_I;
+	$whichtime = 'User+System';
+	$whichtime = 'System' if defined $opt_s;
+	$whichtime = 'Real' if defined $opt_r;
+	$whichtime = 'User' if defined $opt_u;
+
+	if( defined $opt_p ){
+		my $prof = 'DProf';
+		my $startperl = $Config{'startperl'};
+
+		$startperl =~ s/^#!//; # remove shebang
+		run_profiler( $opt_p, $prof, $startperl );
+		$Monfile = 'tmon.out';  # because that's where it is
+		exit(0) if defined $opt_Q;
+	}
+	elsif( defined $opt_Q ){
+		die "-Q is meaningful only when used with -p\n";
+	}
+}
+
+Main: {
+	my $monout = $Monfile;
+	my $fh = 'main::fh';
+	local $names = {};
+	local $times = {};   # times in hz
+	local $ctimes = {};  # Cumulative times in hz
+	local $calls = {};
+	local $persecs = {}; # times in seconds
+	local $idkeys = [];
+	local $runtime; # runtime in seconds
+	my @a = ();
+	my $a;
+	local $rrun_utime = 0;	# user time in hz
+	local $rrun_stime = 0;	# system time in hz
+	local $rrun_rtime = 0;	# elapsed run time in hz
+	local $rrun_ustime = 0;	# user+system time in hz
+	local $hz = 0;
+	local $deep_times = {count => 0 , kids => {}, incl_time => 0};
+	local $time_precision = 2;
+	local $overhead = 0;
+
+	open( $fh, "<$monout" ) || die "Unable to open $monout\n";
+
+	header($fh);
+
+	$rrun_ustime = $rrun_utime + $rrun_stime;
+
+	$~ = 'STAT';
+	if( ! $opt_q ){
+		$^ = 'CSTAT_top';
+	}
+
+	parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
+
+	#filter calls
+	if( $opt_f ){
+		for(my $i = 0;$i < @$idkeys - 2;){
+			$key = $$idkeys[$i];
+			if($key =~ /$opt_f/){
+				splice(@$idkeys, $i, 1);
+				$runtime -= $$times{$key};
+				next;
+			}
+			$i++;
+		}
+	}
+
+	if( $opt_G ){
+		group($names, $calls, $times, $ctimes, $idkeys );
+	}
+
+	settime( \$runtime, $hz ) unless $opt_g;
+
+	exit(0) if $opt_T || $opt_t;
+
+	if( $opt_v ){
+		percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
+	}
+	if( ! $opt_U ){
+		@a = sort $sort @$idkeys;
+		$a = \@a;
+	}
+	else {
+		$a = $idkeys;
+	}
+	display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
+		 $deep_times);
+}
+
+sub group{
+	my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
+		print "Option G Grouping: [$opt_G]\n";
+		# create entries to store grouping
+		$$names{$opt_G} = $opt_G;
+		$$calls{$opt_G} = 0;
+		$$times{$opt_G} = 0;
+		$$ctimes{$opt_G} = 0;
+		$$idkeys[@$idkeys] = $opt_G;
+		# Sum calls for the grouping
+
+		my $other = "other";
+		if($opt_P){
+			$$names{$other} = $other;
+			$$calls{$other} = 0;
+			$$times{$other} = 0;
+			$$ctimes{$other} = 0;
+			$$idkeys[@$idkeys] = $other;
+		}
+
+		for(my $i = 0;$i < @$idkeys - 2;){
+			$key = $$idkeys[$i];
+			if($key =~ /$opt_G/){
+				$$calls{$opt_G} += $$calls{$key};
+				$$times{$opt_G} += $$times{$key};
+				$$ctimes{$opt_G} += $$ctimes{$key};
+				splice(@$idkeys, $i, 1);
+				next;
+			}else{
+				if($opt_P){
+					$$calls{$other} += $$calls{$key};
+					$$times{$other} += $$times{$key};
+					$$ctimes{$other} += $$ctimes{$key};
+					splice(@$idkeys, $i, 1);
+					next;
+				}
+			}
+			$i++;
+		}
+		print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
+			  "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
+			  "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
+}
+
+# Sets $runtime to user, system, real, or user+system time.  The
+# result is given in seconds.
+#
+sub settime {
+  my( $runtime, $hz ) = @_;
+
+  $hz ||= 1;
+  
+  if( $opt_r ){
+    $$runtime = ($rrun_rtime - $overhead)/$hz;
+  }
+  elsif( $opt_s ){
+    $$runtime = ($rrun_stime - $overhead)/$hz;
+  }
+  elsif( $opt_u ){
+    $$runtime = ($rrun_utime - $overhead)/$hz;
+  }
+  else{
+    $$runtime = ($rrun_ustime - $overhead)/$hz;
+  }
+  $$runtime = 0 unless $$runtime > 0;
+}
+
+sub exclusives_in_tree {
+  my( $deep_times ) = @_;
+  my $kids_time = 0;
+  my $kid;
+  # When summing, take into account non-rounded-up kids time.
+  for $kid (keys %{$deep_times->{kids}}) {
+    $kids_time += $deep_times->{kids}{$kid}{incl_time};
+  }
+  $kids_time = 0 unless $kids_time >= 0;
+  $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
+  $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
+  for $kid (keys %{$deep_times->{kids}}) {
+    exclusives_in_tree($deep_times->{kids}{$kid});
+  }
+  $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
+  $deep_times->{kids_time} = $kids_time;
+}
+
+sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time} 
+		   or $a cmp $b }
+
+sub display_tree {
+  my( $deep_times, $name, $level ) = @_;
+  exclusives_in_tree($deep_times);
+  
+  my $kid;
+
+  my $time;
+  if (%{$deep_times->{kids}}) {
+    $time = sprintf '%.*fs = (%.*f + %.*f)', 
+      $time_precision, $deep_times->{incl_time}/$hz,
+        $time_precision, $deep_times->{excl_time}/$hz,
+          $time_precision, $deep_times->{kids_time}/$hz;
+  } else {
+    $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
+  }
+  print ' ' x (2*$level), "$name x $deep_times->{count}  \t${time}s\n"
+    if $deep_times->{count};
+
+  for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
+    display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
+  }  
+}
+
+# Report the times in seconds.
+sub display {
+	my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, 
+	    $idkeys, $deep_times ) = @_;
+	my( $x, $key, $s, $cs );
+	#format: $ncalls, $name, $secs, $percall, $pcnt
+
+	if ($opt_S) {
+	  display_tree( $deep_times, 'toplevel', -1 )
+	} else {
+	  for( $x = 0; $x < @$idkeys; ++$x ){
+	    $key = $idkeys->[$x];
+	    $ncalls = $calls->{$key};
+	    $name = $names->{$key};
+	    $s = $times->{$key}/$hz;
+	    $secs = sprintf("%.3f", $s );
+	    $cs = $ctimes->{$key}/$hz;
+	    $csecs = sprintf("%.3f", $cs );
+	    $percall = sprintf("%.4f", $s/$ncalls );
+	    $cpercall = sprintf("%.4f", $cs/$ncalls );
+	    $pcnt = sprintf("%.2f",
+			    $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
+	    write;
+	    $pcnt = $secs = $ncalls = $percall = "";
+	    write while( length $name );
+	    last unless --$cnt;
+	  }	  
+	}
+}
+
+sub move_keys {
+  my ($source, $dest) = @_;
+
+  for my $kid_name (keys %$source) {
+    my $source_kid = delete $source->{$kid_name};
+
+    if (my $dest_kid = $dest->{$kid_name}) {
+      $dest_kid->{count} += $source_kid->{count};
+      $dest_kid->{incl_time} += $source_kid->{incl_time};
+      move_keys($source_kid->{kids},$dest_kid->{kids});
+    } else {
+      $dest->{$kid_name} = $source_kid;
+    }
+  }
+}
+
+sub add_to_tree {
+  my ($curdeep_times, $name, $t) = @_;
+  if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
+    $name = $curdeep_times->[-1]{name};
+  }
+  die "Shorted?!" unless @$curdeep_times >= 2;
+  my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
+    count => 0,
+    kids => {}, 
+    incl_time => 0,
+  };
+  # Now transfer to the new node (could not do earlier, since name can change)
+  $entry->{count}++;
+  $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
+  # Merge the kids?
+  move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
+  pop @$curdeep_times;
+}
+
+
+sub parsestack {
+	my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
+	my( $dir, $name );
+	my( $t, $syst, $realt, $usert );
+	my( $x, $z, $c, $id, $pack );
+	my @stack = ();
+	my @tstack = ();
+	my %outer;
+	my $tab = 3;
+	my $in = 0;
+
+	# remember last call depth and function name
+	my $l_in = $in;
+	my $l_name = '';
+	my $repcnt = 0;
+	my $repstr = '';
+	my $dprof_stamp;
+	my %cv_hash;
+	my $in_level = not defined $opt_g; # Level deep in report grouping
+	my $curdeep_times = [$deep_times];
+
+	my $over_per_call;
+	if   ( $opt_u )	{	$over_per_call = $over_utime		}
+	elsif( $opt_s )	{	$over_per_call = $over_stime		}
+	elsif( $opt_r )	{	$over_per_call = $over_rtime		}
+	else		{	$over_per_call = $over_utime + $over_stime }
+	$over_per_call /= 2*$over_tests; # distribute over entry and exit
+
+	while(<$fh>){
+		next if /^#/;
+		last if /^PART/;
+
+		chop;
+		if (/^&/) {
+		  ($dir, $id, $pack, $name) = split;
+		  if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
+		    $name .= "($id)";
+		  }
+		  $cv_hash{$id} = "$pack\::$name";
+		  next;
+		}
+		($dir, $usert, $syst, $realt, $name) = split;
+
+		my $ot = $t;
+		if ( $dir eq '/' ) {
+		  $syst = $stack[-1][0] if scalar @stack;
+		  $usert = '&';
+		  $dir = '-';
+		  #warn("Inserted exit for $stack[-1][0].\n")
+		}
+		if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
+		  if   ( $opt_u )	{	$t = $usert		}
+		  elsif( $opt_s )	{	$t = $syst		}
+		  elsif( $opt_r )	{	$t = $realt		}
+		  else			{	$t = $usert + $syst	}
+		  $t += $ot, next if $dir eq '@'; # Increments there
+		} else {
+		  # "- id" or "- & name"
+		  $name = defined $syst ? $syst : $cv_hash{$usert};
+		}
+
+		next unless $in_level or $name eq $opt_g;
+		if ( $dir eq '-' or $dir eq '*' ) {
+		  	my $ename = $dir eq '*' ? $stack[-1][0]  : $name;
+			$overhead += $over_per_call;
+		  	if ($name eq "Devel::DProf::write") {
+			  $overhead += $t - $dprof_stamp;
+			  next;
+		  	} elsif (defined $opt_g and $ename eq $opt_g) {
+			  $in_level--;
+			}
+			add_to_tree($curdeep_times, $ename,
+				    $t - $overhead) if $opt_S;
+			exitstamp( \@stack, \@tstack,
+				   $t - $overhead,
+				   $times, $ctimes, $name, \$in, $tab,
+				   $curdeep_times, \%outer );
+		} 
+		next unless $in_level or $name eq $opt_g;
+		if( $dir eq '+' or $dir eq '*' ){
+		  	if ($name eq "Devel::DProf::write") {
+			  $dprof_stamp = $t;
+			  next;
+		  	} elsif (defined $opt_g and $name eq $opt_g) {
+			  $in_level++;
+		  	}
+			$overhead += $over_per_call;
+			if( $opt_T ){
+				print ' ' x $in, "$name\n";
+				$in += $tab;
+			}
+			elsif( $opt_t ){
+				# suppress output on same function if the
+				# same calling level is called.
+				if ($l_in == $in and $l_name eq $name) {
+					$repcnt++;
+				} else {
+					$repstr = ' ('.++$repcnt.'x)'
+						 if $repcnt;
+					print ' ' x $l_in, "$l_name$repstr\n"
+						if $l_name ne '';
+					$repstr = '';
+					$repcnt = 0;
+					$l_in = $in;
+					$l_name = $name;
+				}
+				$in += $tab;
+			}
+			if( ! defined $names->{$name} ){
+				$names->{$name} = $name;
+				$times->{$name} = 0;
+				$ctimes->{$name} = 0;
+				push( @$idkeys, $name );
+			}
+			$calls->{$name}++;
+                        $outer{$name}++;
+			push @$curdeep_times, { kids => {}, 
+						name => $name, 
+						enter_stamp => $t - $overhead,
+					      } if $opt_S;
+			$x = [ $name, $t - $overhead ];
+			push( @stack, $x );
+
+			# my children will put their time here
+			push( @tstack, 0 );
+		} elsif ($dir ne '-'){
+		    die "Bad profile: $_";
+	        }
+	}
+	if( $opt_t ){
+		$repstr = ' ('.++$repcnt.'x)' if $repcnt;
+		print ' ' x $l_in, "$l_name$repstr\n";
+	}
+
+        while (my ($key, $count) = each %outer) {
+            next unless $count;
+            warn "$key has $count unstacked calls in outer\n";
+        }
+
+	if( @stack ){
+		if( ! $opt_F ){
+			warn "Garbled profile is missing some exit time stamps:\n";
+			foreach $x (@stack) {
+				print $x->[0],"\n";
+			}
+			die "Try rerunning dprofpp with -F.\n";
+			# I don't want -F to be default behavior--yet
+			#  9/18/95 dmr
+		}
+		else{
+			warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
+			foreach $x ( reverse @stack ){
+				$name = $x->[0];
+				exitstamp( \@stack, \@tstack, 
+					   $t - $overhead, $times, 
+					   $ctimes, $name, \$in, $tab, 
+					   $curdeep_times, \%outer );
+				add_to_tree($curdeep_times, $name,
+					    $t - $overhead)
+				  if $opt_S;
+			}
+		}
+	}
+	if (defined $opt_g) {
+	  $runtime = $ctimes->{$opt_g}/$hz;
+	  $runtime = 0 unless $runtime > 0;
+	}
+}
+
+sub exitstamp {
+	my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
+	my( $x, $c, $z );
+
+	$x = pop( @$stack );
+	if( ! defined $x ){
+		die "Garbled profile, missing an enter time stamp";
+	}
+	if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
+	  if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
+	    if ($opt_A) {
+	      $name = $x->[0];
+	    }
+	  } elsif ( $opt_F ) {
+	    warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
+	    $name = $x->[0];
+	  } else {
+	    foreach $z (@stack, $x) {
+	      print $z->[0],"\n";
+	    }
+	    die "Garbled profile, unexpected exit time stamp";
+	  }
+	}
+	if( $opt_T || $opt_t ){
+		$$in -= $tab;
+	}
+	# collect childtime
+	$c = pop( @$tstack );
+	# total time this func has been active
+	$z = $t - $x->[1];
+	$ctimes->{$name} += $z
+            unless --$outer->{$name};
+	$times->{$name} += $z - $c;
+	# pass my time to my parent
+	if( @$tstack ){
+		$c = pop( @$tstack );
+		push( @$tstack, $c + $z );
+	}
+}
+
+
+sub header {
+	my $fh = shift;
+	chop($_ = <$fh>);
+	if( ! /^#fOrTyTwO$/ ){
+		die "Not a perl profile";
+	}
+	while(<$fh>){
+		next if /^#/;
+		last if /^PART/;
+		eval;
+	}
+	$over_tests = 1 unless $over_tests;
+	$time_precision = length int ($hz - 1);	# log ;-)
+}
+
+
+# Report avg time-per-function in seconds
+sub percalc {
+	my( $calls, $times, $persecs, $idkeys ) = @_;
+	my( $x, $t, $n, $key );
+
+	for( $x = 0; $x < @$idkeys; ++$x ){
+		$key = $idkeys->[$x];
+		$n = $calls->{$key};
+		$t = $times->{$key} / $hz;
+		$persecs->{$key} = $t ? $t / $n : 0;
+	}
+}
+
+
+# Runs the given script with the given profiler and the given perl.
+sub run_profiler {
+	my $script = shift;
+	my $profiler = shift;
+	my $startperl = shift;
+	my @script_parts = split /\s+/, $script;
+
+	system $startperl, "-d:$profiler", @script_parts;
+	if( $? / 256 > 0 ){
+		my $cmd = join ' ', @script_parts;
+		die "Failed: $startperl -d:$profiler $cmd: $!";
+	}
+}
+
+
+sub by_time { $times->{$b} <=> $times->{$a} }
+sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
+sub by_calls { $calls->{$b} <=> $calls->{$a} }
+sub by_alpha { $names->{$a} cmp $names->{$b} }
+sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
+# Reversed
+sub rby_time { $times->{$a} <=> $times->{$b} }
+sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
+sub rby_calls { $calls->{$a} <=> $calls->{$b} }
+sub rby_alpha { $names->{$b} cmp $names->{$a} }
+sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
+
+
+format CSTAT_top =
+Total Elapsed Time = @>>>>>>> Seconds
+(($rrun_rtime - $overhead) / $hz)
+  @>>>>>>>>>> Time = @>>>>>>> Seconds
+$whichtime, $runtime
+@<<<<<<<< Times
+$incl_excl
+%Time ExclSec CumulS #Calls sec/call Csec/c  Name
+.
+
+BEGIN {
+    my $fmt = ' ^>>>   ^>>>> ^>>>>> ^>>>>>   ^>>>>> ^>>>>>  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
+    if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
+    {
+	$fmt .= '<' x ($cols - length $fmt) if $cols > 80;
+    }
+
+    eval "format STAT = \n$fmt" . '
+$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
+.';
+}
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/enc2xs.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/enc2xs.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/enc2xs.bat	(revision 19631)
@@ -0,0 +1,1404 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if $running_under_some_shell;
+#!./perl
+BEGIN {
+    # @INC poking  no longer needed w/ new MakeMaker and Makefile.PL's
+    # with $ENV{PERL_CORE} set
+    # In case we need it in future...
+    require Config; import Config;
+}
+use strict;
+use warnings;
+use Getopt::Std;
+my @orig_ARGV = @ARGV;
+our $VERSION  = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+# These may get re-ordered.
+# RAW is a do_now as inserted by &enter
+# AGG is an aggreagated do_now, as built up by &process
+
+use constant {
+  RAW_NEXT => 0,
+  RAW_IN_LEN => 1,
+  RAW_OUT_BYTES => 2,
+  RAW_FALLBACK => 3,
+
+  AGG_MIN_IN => 0,
+  AGG_MAX_IN => 1,
+  AGG_OUT_BYTES => 2,
+  AGG_NEXT => 3,
+  AGG_IN_LEN => 4,
+  AGG_OUT_LEN => 5,
+  AGG_FALLBACK => 6,
+};
+
+# (See the algorithm in encengine.c - we're building structures for it)
+
+# There are two sorts of structures.
+# "do_now" (an array, two variants of what needs storing) is whatever we need
+# to do now we've read an input byte.
+# It's housed in a "do_next" (which is how we got to it), and in turn points
+# to a "do_next" which contains all the "do_now"s for the next input byte.
+
+# There will be a "do_next" which is the start state.
+# For a single byte encoding it's the only "do_next" - each "do_now" points
+# back to it, and each "do_now" will cause bytes. There is no state.
+
+# For a multi-byte encoding where all characters in the input are the same
+# length, then there will be a tree of "do_now"->"do_next"->"do_now"
+# branching out from the start state, one step for each input byte.
+# The leaf "do_now"s will all be at the same distance from the start state,
+# only the leaf "do_now"s cause output bytes, and they in turn point back to
+# the start state.
+
+# For an encoding where there are varaible length input byte sequences, you
+# will encounter a leaf "do_now" sooner for the shorter input sequences, but
+# as before the leaves will point back to the start state.
+
+# The system will cope with escape encodings (imagine them as a mostly
+# self-contained tree for each escape state, and cross links between trees
+# at the state-switching characters) but so far no input format defines these.
+
+# The system will also cope with having output "leaves" in the middle of
+# the bifurcating branches, not just at the extremities, but again no
+# input format does this yet.
+
+# There are two variants of the "do_now" structure. The first, smaller variant
+# is generated by &enter as the input file is read. There is one structure
+# for each input byte. Say we are mapping a single byte encoding to a
+# single byte encoding, with  "ABCD" going "abcd". There will be
+# 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
+
+# &process then walks the tree, building aggregate "do_now" structres for
+# adjacent bytes where possible. The aggregate is for a contiguous range of
+# bytes which each produce the same length of output, each move to the
+# same next state, and each have the same fallback flag.
+# So our 4 RAW "do_now"s above become replaced by a single structure
+# containing:
+# ["A", "D", "abcd", 1, ...]
+# ie, for an input byte $_ in "A".."D", output 1 byte, found as
+# substr ("abcd", (ord $_ - ord "A") * 1, 1)
+# which maps very nicely into pointer arithmetic in C for encengine.c
+
+sub encode_U
+{
+ # UTF-8 encode long hand - only covers part of perl's range
+ ## my $uv = shift;
+ # chr() works in native space so convert value from table
+ # into that space before using chr().
+ my $ch = chr(utf8::unicode_to_native($_[0]));
+ # Now get core perl to encode that the way it likes.
+ utf8::encode($ch);
+ return $ch;
+}
+
+sub encode_S
+{
+ # encode single byte
+ ## my ($ch,$page) = @_; return chr($ch);
+ return chr $_[0];
+}
+
+sub encode_D
+{
+ # encode double byte MS byte first
+ ## my ($ch,$page) = @_; return chr($page).chr($ch);
+ return chr ($_[1]) . chr $_[0];
+}
+
+sub encode_M
+{
+ # encode Multi-byte - single for 0..255 otherwise double
+ ## my ($ch,$page) = @_;
+ ## return &encode_D if $page;
+ ## return &encode_S;
+ return chr ($_[1]) . chr $_[0] if $_[1];
+ return chr $_[0];
+}
+
+my %encode_types = (U => \&encode_U,
+                    S => \&encode_S,
+                    D => \&encode_D,
+                    M => \&encode_M,
+                   );
+
+# Win32 does not expand globs on command line
+eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
+
+my %opt;
+# I think these are:
+# -Q to disable the duplicate codepoint test
+# -S make mapping errors fatal
+# -q to remove comments written to output files
+# -O to enable the (brute force) substring optimiser
+# -o <output> to specify the output file name (else it's the first arg)
+# -f <inlist> to give a file with a list of input files (else use the args)
+# -n <name> to name the encoding (else use the basename of the input file.
+getopts('CM:SQqOo:f:n:',\%opt);
+
+$opt{M} and make_makefile_pl($opt{M}, @ARGV);
+$opt{C} and make_configlocal_pm($opt{C}, @ARGV);
+
+# This really should go first, else the die here causes empty (non-erroneous)
+# output files to be written.
+my @encfiles;
+if (exists $opt{'f'}) {
+    # -F is followed by name of file containing list of filenames
+    my $flist = $opt{'f'};
+    open(FLIST,$flist) || die "Cannot open $flist:$!";
+    chomp(@encfiles = <FLIST>);
+    close(FLIST);
+} else {
+    @encfiles = @ARGV;
+}
+
+my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
+chmod(0666,$cname) if -f $cname && !-w $cname;
+open(C,">$cname") || die "Cannot open $cname:$!";
+
+my $dname = $cname;
+my $hname = $cname;
+
+my ($doC,$doEnc,$doUcm,$doPet);
+
+if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined
+ {
+  $doC = 1;
+  $dname =~ s/(\.[^\.]*)?$/.exh/;
+  chmod(0666,$dname) if -f $cname && !-w $dname;
+  open(D,">$dname") || die "Cannot open $dname:$!";
+  $hname =~ s/(\.[^\.]*)?$/.h/;
+  chmod(0666,$hname) if -f $cname && !-w $hname;
+  open(H,">$hname") || die "Cannot open $hname:$!";
+
+  foreach my $fh (\*C,\*D,\*H)
+  {
+   print $fh <<"END" unless $opt{'q'};
+/*
+ !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
+ This file was autogenerated by:
+ $^X $0 @orig_ARGV
+*/
+END
+  }
+
+  if ($cname =~ /(\w+)\.xs$/)
+   {
+    print C "#include <EXTERN.h>\n";
+    print C "#include <perl.h>\n";
+    print C "#include <XSUB.h>\n";
+    print C "#define U8 U8\n";
+   }
+  print C "#include \"encode.h\"\n\n";
+
+ }
+elsif ($cname =~ /\.enc$/)
+ {
+  $doEnc = 1;
+ }
+elsif ($cname =~ /\.ucm$/)
+ {
+  $doUcm = 1;
+ }
+elsif ($cname =~ /\.pet$/)
+ {
+  $doPet = 1;
+ }
+
+my %encoding;
+my %strings;
+my $string_acc;
+my %strings_in_acc;
+
+my $saved = 0;
+my $subsave = 0;
+my $strings = 0;
+
+sub cmp_name
+{
+ if ($a =~ /^.*-(\d+)/)
+  {
+   my $an = $1;
+   if ($b =~ /^.*-(\d+)/)
+    {
+     my $r = $an <=> $1;
+     return $r if $r;
+    }
+  }
+ return $a cmp $b;
+}
+
+
+foreach my $enc (sort cmp_name @encfiles)
+ {
+  my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
+  $name = $opt{'n'} if exists $opt{'n'};
+  if (open(E,$enc))
+   {
+    if ($sfx eq 'enc')
+     {
+      compile_enc(\*E,lc($name));
+     }
+    else
+     {
+      compile_ucm(\*E,lc($name));
+     }
+   }
+  else
+   {
+    warn "Cannot open $enc for $name:$!";
+   }
+ }
+
+if ($doC)
+ {
+  print STDERR "Writing compiled form\n";
+  foreach my $name (sort cmp_name keys %encoding)
+   {
+    my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+    process($name.'_utf8',$e2u);
+    addstrings(\*C,$e2u);
+
+    process('utf8_'.$name,$u2e);
+    addstrings(\*C,$u2e);
+   }
+  outbigstring(\*C,"enctable");
+  foreach my $name (sort cmp_name keys %encoding)
+   {
+    my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+    outtable(\*C,$e2u, "enctable");
+    outtable(\*C,$u2e, "enctable");
+
+    # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
+   }
+  foreach my $enc (sort cmp_name keys %encoding)
+   {
+    # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
+    my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}};
+    #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
+    my $replen = 0; 
+    $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g);
+    my @info = ($e2u->{Cname},$u2e->{Cname},qq((U8 *)"$rep"),$replen,$min_el,$max_el);
+    my $sym = "${enc}_encoding";
+    $sym =~ s/\W+/_/g;
+    print C "encode_t $sym = \n";
+    # This is to make null encoding work -- dankogai
+    for (my $i = (scalar @info) - 1;  $i >= 0; --$i){
+	$info[$i] ||= 1;
+    }
+    # end of null tweak -- dankogai
+    print C " {",join(',',@info,"{\"$enc\",(const char *)0}"),"};\n\n";
+   }
+
+  foreach my $enc (sort cmp_name keys %encoding)
+   {
+    my $sym = "${enc}_encoding";
+    $sym =~ s/\W+/_/g;
+    print H "extern encode_t $sym;\n";
+    print D " Encode_XSEncoding(aTHX_ &$sym);\n";
+   }
+
+  if ($cname =~ /(\w+)\.xs$/)
+   {
+    my $mod = $1;
+    print C <<'END';
+
+static void
+Encode_XSEncoding(pTHX_ encode_t *enc)
+{
+ dSP;
+ HV *stash = gv_stashpv("Encode::XS", TRUE);
+ SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
+ int i = 0;
+ PUSHMARK(sp);
+ XPUSHs(sv);
+ while (enc->name[i])
+  {
+   const char *name = enc->name[i++];
+   XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
+  }
+ PUTBACK;
+ call_pv("Encode::define_encoding",G_DISCARD);
+ SvREFCNT_dec(sv);
+}
+
+END
+
+    print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
+    print C "BOOT:\n{\n";
+    print C "#include \"$dname\"\n";
+    print C "}\n";
+   }
+  # Close in void context is bad, m'kay
+  close(D) or warn "Error closing '$dname': $!";
+  close(H) or warn "Error closing '$hname': $!";
+
+  my $perc_saved    = $saved/($strings + $saved) * 100;
+  my $perc_subsaved = $subsave/($strings + $subsave) * 100;
+  printf STDERR "%d bytes in string tables\n",$strings;
+  printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
+    $saved, $perc_saved              if $saved;
+  printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
+    $subsave, $perc_subsaved         if $subsave;
+ }
+elsif ($doEnc)
+ {
+  foreach my $name (sort cmp_name keys %encoding)
+   {
+    my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+    output_enc(\*C,$name,$e2u);
+   }
+ }
+elsif ($doUcm)
+ {
+  foreach my $name (sort cmp_name keys %encoding)
+   {
+    my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+    output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
+   }
+ }
+
+# writing half meg files and then not checking to see if you just filled the
+# disk is bad, m'kay
+close(C) or die "Error closing '$cname': $!";
+
+# End of the main program.
+
+sub compile_ucm
+{
+ my ($fh,$name) = @_;
+ my $e2u = {};
+ my $u2e = {};
+ my $cs;
+ my %attr;
+ while (<$fh>)
+  {
+   s/#.*$//;
+   last if /^\s*CHARMAP\s*$/i;
+   if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
+    {
+     $attr{$1} = $2;
+    }
+  }
+ if (!defined($cs =  $attr{'code_set_name'}))
+  {
+   warn "No <code_set_name> in $name\n";
+  }
+ else
+  {
+   $name = $cs unless exists $opt{'n'};
+  }
+ my $erep;
+ my $urep;
+ my $max_el;
+ my $min_el;
+ if (exists $attr{'subchar'})
+  {
+   #my @byte;
+   #$attr{'subchar'} =~ /^\s*/cg;
+   #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
+   #$erep = join('',map(chr(hex($_)),@byte));
+   $erep = $attr{'subchar'}; 
+   $erep =~ s/^\s+//; $erep =~ s/\s+$//;
+  }
+ print "Reading $name ($cs)\n";
+ my $nfb = 0;
+ my $hfb = 0;
+ while (<$fh>)
+  {
+   s/#.*$//;
+   last if /^\s*END\s+CHARMAP\s*$/i;
+   next if /^\s*$/;
+   my (@uni, @byte) = ();
+   my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o
+       or die "Bad line: $_";
+   while ($uni =~  m/\G<([U0-9a-fA-F\+]+)>/g){
+       push @uni, map { substr($_, 1) } split(/\+/, $1);
+   }
+   while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){
+       push @byte, $1;
+   }
+   if (@uni)
+    {
+     my $uch =  join('', map { encode_U(hex($_)) } @uni );
+     my $ech = join('',map(chr(hex($_)),@byte));
+     my $el  = length($ech);
+     $max_el = $el if (!defined($max_el) || $el > $max_el);
+     $min_el = $el if (!defined($min_el) || $el < $min_el);
+     if (length($fb))
+      {
+       $fb = substr($fb,1);
+       $hfb++;
+      }
+     else
+      {
+       $nfb++;
+       $fb = '0';
+      }
+     # $fb is fallback flag
+     # 0 - round trip safe
+     # 1 - fallback for unicode -> enc
+     # 2 - skip sub-char mapping
+     # 3 - fallback enc -> unicode
+     enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
+     enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
+    }
+   else
+    {
+     warn $_;
+    }
+  }
+ if ($nfb && $hfb)
+  {
+   die "$nfb entries without fallback, $hfb entries with\n";
+  }
+ $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
+}
+
+
+
+sub compile_enc
+{
+ my ($fh,$name) = @_;
+ my $e2u = {};
+ my $u2e = {};
+
+ my $type;
+ while ($type = <$fh>)
+  {
+   last if $type !~ /^\s*#/;
+  }
+ chomp($type);
+ return if $type eq 'E';
+ # Do the hash lookup once, rather than once per function call. 4% speedup.
+ my $type_func = $encode_types{$type};
+ my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
+ warn "$type encoded $name\n";
+ my $rep = '';
+ # Save a defined test by setting these to defined values.
+ my $min_el = ~0; # A very big integer
+ my $max_el = 0;  # Anything must be longer than 0
+ {
+  my $v = hex($def);
+  $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
+ }
+ my $errors;
+ my $seen;
+ # use -Q to silence the seen test. Makefile.PL uses this by default.
+ $seen = {} unless $opt{Q};
+ do
+  {
+   my $line = <$fh>;
+   chomp($line);
+   my $page = hex($line);
+   my $ch = 0;
+   my $i = 16;
+   do
+    {
+     # So why is it 1% faster to leave the my here?
+     my $line = <$fh>;
+     $line =~ s/\r\n$/\n/;
+     die "$.:${line}Line should be exactly 65 characters long including
+     newline (".length($line).")" unless length ($line) == 65;
+     # Split line into groups of 4 hex digits, convert groups to ints
+     # This takes 65.35		
+     # map {hex $_} $line =~ /(....)/g
+     # This takes 63.75 (2.5% less time)
+     # unpack "n*", pack "H*", $line
+     # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
+     # Doing it as while ($line =~ /(....)/g) took 74.63
+     foreach my $val (unpack "n*", pack "H*", $line)
+      {
+       next if $val == 0xFFFD;
+       my $ech = &$type_func($ch,$page);
+       if ($val || (!$ch && !$page))
+        {
+         my $el  = length($ech);
+         $max_el = $el if $el > $max_el;
+         $min_el = $el if $el < $min_el;
+         my $uch = encode_U($val);
+         if ($seen) {
+           # We're doing the test.
+           # We don't need to read this quickly, so storing it as a scalar,
+           # rather than 3 (anon array, plus the 2 scalars it holds) saves
+           # RAM and may make us faster on low RAM systems. [see __END__]
+           if (exists $seen->{$uch})
+             {
+               warn sprintf("U%04X is %02X%02X and %04X\n",
+                            $val,$page,$ch,$seen->{$uch});
+               $errors++;
+             }
+           else
+             {
+               $seen->{$uch} = $page << 8 | $ch;
+             }
+         }
+         # Passing 2 extra args each time is 3.6% slower!
+         # Even with having to add $fallback ||= 0 later
+         enter_fb0($e2u,$ech,$uch);
+         enter_fb0($u2e,$uch,$ech);
+        }
+       else
+        {
+         # No character at this position
+         # enter($e2u,$ech,undef,$e2u);
+        }
+       $ch++;
+      }
+    } while --$i;
+  } while --$pages;
+ die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
+   if $min_el > $max_el;
+ die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
+ $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
+}
+
+# my ($a,$s,$d,$t,$fb) = @_;
+sub enter {
+  my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
+  # state we shift to after this (multibyte) input character defaults to same
+  # as current state.
+  $next ||= $current;
+  # Making sure it is defined seems to be faster than {no warnings;} in
+  # &process, or passing it in as 0 explicity.
+  # XXX $fallback ||= 0;
+
+  # Start at the beginning and work forwards through the string to zero.
+  # effectively we are removing 1 character from the front each time
+  # but we don't actually edit the string. [this alone seems to be 14% speedup]
+  # Hence -$pos is the length of the remaining string.
+  my $pos = -length $inbytes;
+  while (1) {
+    my $byte = substr $inbytes, $pos, 1;
+    #  RAW_NEXT => 0,
+    #  RAW_IN_LEN => 1,
+    #  RAW_OUT_BYTES => 2,
+    #  RAW_FALLBACK => 3,
+    # to unicode an array would seem to be better, because the pages are dense.
+    # from unicode can be very sparse, favouring a hash.
+    # hash using the bytes (all length 1) as keys rather than ord value,
+    # as it's easier to sort these in &process.
+
+    # It's faster to always add $fallback even if it's undef, rather than
+    # choosing between 3 and 4 element array. (hence why we set it defined
+    # above)
+    my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
+    # When $pos was -1 we were at the last input character.
+    unless (++$pos) {
+      $do_now->[RAW_OUT_BYTES] = $outbytes;
+      $do_now->[RAW_NEXT] = $next;
+      return;
+    }
+    # Tail recursion. The intermdiate state may not have a name yet.
+    $current = $do_now->[RAW_NEXT];
+  }
+}
+
+# This is purely for optimistation. It's just &enter hard coded for $fallback
+# of 0, using only a 3 entry array ref to save memory for every entry.
+sub enter_fb0 {
+  my ($current,$inbytes,$outbytes,$next) = @_;
+  $next ||= $current;
+
+  my $pos = -length $inbytes;
+  while (1) {
+    my $byte = substr $inbytes, $pos, 1;
+    my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
+    unless (++$pos) {
+      $do_now->[RAW_OUT_BYTES] = $outbytes;
+      $do_now->[RAW_NEXT] = $next;
+      return;
+    }
+    $current = $do_now->[RAW_NEXT];
+  }
+}
+
+sub process
+{
+  my ($name,$a) = @_;
+  $name =~ s/\W+/_/g;
+  $a->{Cname} = $name;
+  my $raw = $a->{Raw};
+  my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
+  my @ent;
+  $agg_max_in = 0;
+  foreach my $key (sort keys %$raw) {
+    #  RAW_NEXT => 0,
+    #  RAW_IN_LEN => 1,
+    #  RAW_OUT_BYTES => 2,
+    #  RAW_FALLBACK => 3,
+    my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
+    # Now we are converting from raw to aggregate, switch from 1 byte strings
+    # to numbers
+    my $b = ord $key;
+    $fallback ||= 0;
+    if ($l &&
+        # If this == fails, we're going to reset $agg_max_in below anyway.
+        $b == ++$agg_max_in &&
+        # References in numeric context give the pointer as an int.
+        $agg_next == $next &&
+        $agg_in_len == $in_len &&
+        $agg_out_len == length $out_bytes &&
+        $agg_fallback == $fallback
+        # && length($l->[AGG_OUT_BYTES]) < 16
+       ) {
+      #     my $i = ord($b)-ord($l->[AGG_MIN_IN]);
+      # we can aggregate this byte onto the end.
+      $l->[AGG_MAX_IN] = $b;
+      $l->[AGG_OUT_BYTES] .= $out_bytes;
+    } else {
+      # AGG_MIN_IN => 0,
+      # AGG_MAX_IN => 1,
+      # AGG_OUT_BYTES => 2,
+      # AGG_NEXT => 3,
+      # AGG_IN_LEN => 4,
+      # AGG_OUT_LEN => 5,
+      # AGG_FALLBACK => 6,
+      # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
+      # (only gains .6% on euc-jp  -- is it worth it?)
+      push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
+                       $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
+                       $agg_fallback = $fallback];
+    }
+    if (exists $next->{Cname}) {
+      $next->{'Forward'} = 1 if $next != $a;
+    } else {
+      process(sprintf("%s_%02x",$name,$b),$next);
+    }
+  }
+  # encengine.c rules say that last entry must be for 255
+  if ($agg_max_in < 255) {
+    push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
+  }
+  $a->{'Entries'} = \@ent;
+}
+
+
+sub addstrings
+{
+ my ($fh,$a) = @_;
+ my $name = $a->{'Cname'};
+ # String tables
+ foreach my $b (@{$a->{'Entries'}})
+  {
+   next unless $b->[AGG_OUT_LEN];
+   $strings{$b->[AGG_OUT_BYTES]} = undef;
+  }
+ if ($a->{'Forward'})
+  {
+   my $var = $^O eq 'MacOS' ? 'extern' : 'static';
+   print $fh "$var encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
+  }
+ $a->{'DoneStrings'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+  {
+   my ($s,$e,$out,$t,$end,$l) = @$b;
+   addstrings($fh,$t) unless $t->{'DoneStrings'};
+  }
+}
+
+sub outbigstring
+{
+  my ($fh,$name) = @_;
+
+  $string_acc = '';
+
+  # Make the big string in the string accumulator. Longest first, on the hope
+  # that this makes it more likely that we find the short strings later on.
+  # Not sure if it helps sorting strings of the same length lexcically.
+  foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) {
+    my $index = index $string_acc, $s;
+    if ($index >= 0) {
+      $saved += length($s);
+      $strings_in_acc{$s} = $index;
+    } else {
+    OPTIMISER: {
+	if ($opt{'O'}) {
+	  my $sublength = length $s;
+	  while (--$sublength > 0) {
+	    # progressively lop characters off the end, to see if the start of
+	    # the new string overlaps the end of the accumulator.
+	    if (substr ($string_acc, -$sublength)
+		eq substr ($s, 0, $sublength)) {
+	      $subsave += $sublength;
+	      $strings_in_acc{$s} = length ($string_acc) - $sublength;
+	      # append the last bit on the end.
+	      $string_acc .= substr ($s, $sublength);
+	      last OPTIMISER;
+	    }
+	    # or if the end of the new string overlaps the start of the
+	    # accumulator
+	    next unless substr ($string_acc, 0, $sublength)
+	      eq substr ($s, -$sublength);
+	    # well, the last $sublength characters of the accumulator match.
+	    # so as we're prepending to the accumulator, need to shift all our
+	    # existing offsets forwards
+	    $_ += $sublength foreach values %strings_in_acc;
+	    $subsave += $sublength;
+	    $strings_in_acc{$s} = 0;
+	    # append the first bit on the start.
+	    $string_acc = substr ($s, 0, -$sublength) . $string_acc;
+	    last OPTIMISER;
+	  }
+	}
+	# Optimiser (if it ran) found nothing, so just going have to tack the
+	# whole thing on the end.
+	$strings_in_acc{$s} = length $string_acc;
+	$string_acc .= $s;
+      };
+    }
+  }
+
+  $strings = length $string_acc;
+  my $definition = "\nstatic const U8 $name\[$strings] = { " .
+    join(',',unpack "C*",$string_acc);
+  # We have a single long line. Split it at convenient commas.
+  print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs;
+  print $fh substr ($definition, pos $definition), " };\n";
+}
+
+sub findstring {
+  my ($name,$s) = @_;
+  my $offset = $strings_in_acc{$s};
+  die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator"
+    unless defined $offset;
+  "$name + $offset";
+}
+
+sub outtable
+{
+ my ($fh,$a,$bigname) = @_;
+ my $name = $a->{'Cname'};
+ $a->{'Done'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+  {
+   my ($s,$e,$out,$t,$end,$l) = @$b;
+   outtable($fh,$t,$bigname) unless $t->{'Done'};
+  }
+ print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n";
+ foreach my $b (@{$a->{'Entries'}})
+  {
+   my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
+   # $end |= 0x80 if $fb; # what the heck was on your mind, Nick?  -- Dan
+   print  $fh "{";
+   if ($l)
+    {
+     printf $fh findstring($bigname,$out);
+    }
+   else
+    {
+     print  $fh "0";
+    }
+   print  $fh ",",$t->{Cname};
+   printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
+  }
+ print $fh "};\n";
+}
+
+sub output_enc
+{
+ my ($fh,$name,$a) = @_;
+ die "Changed - fix me for new structure";
+ foreach my $b (sort keys %$a)
+  {
+   my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
+  }
+}
+
+sub decode_U
+{
+ my $s = shift;
+}
+
+my @uname;
+sub char_names
+{
+ my $s = do "unicore/Name.pl";
+ die "char_names: unicore/Name.pl: $!\n" unless defined $s;
+ pos($s) = 0;
+ while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
+  {
+   my $name = $3;
+   my $s = hex($1);
+   last if $s >= 0x10000;
+   my $e = length($2) ? hex($2) : $s;
+   for (my $i = $s; $i <= $e; $i++)
+    {
+     $uname[$i] = $name;
+#    print sprintf("U%04X $name\n",$i);
+    }
+  }
+}
+
+sub output_ucm_page
+{
+  my ($cmap,$a,$t,$pre) = @_;
+  # warn sprintf("Page %x\n",$pre);
+  my $raw = $t->{Raw};
+  foreach my $key (sort keys %$raw) {
+    #  RAW_NEXT => 0,
+    #  RAW_IN_LEN => 1,
+    #  RAW_OUT_BYTES => 2,
+    #  RAW_FALLBACK => 3,
+    my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
+    my $u = ord $key;
+    $fallback ||= 0;
+
+    if ($next != $a && $next != $t) {
+      output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
+    } elsif (length $out_bytes) {
+      if ($pre) {
+        $u = $pre|($u &0x3f);
+      }
+      my $s = sprintf "<U%04X> ",$u;
+      #foreach my $c (split(//,$out_bytes)) {
+      #  $s .= sprintf "\\x%02X",ord($c);
+      #}
+      # 9.5% faster changing that loop to this:
+      $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
+      $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
+      push(@$cmap,$s);
+    } else {
+      warn join(',',$u, @{$raw->{$key}},$a,$t);
+    }
+  }
+}
+
+sub output_ucm
+{
+ my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
+ print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
+ print $fh "<code_set_name> \"$name\"\n";
+ char_names();
+ if (defined $min_el)
+  {
+   print $fh "<mb_cur_min> $min_el\n";
+  }
+ if (defined $max_el)
+  {
+   print $fh "<mb_cur_max> $max_el\n";
+  }
+ if (defined $rep)
+  {
+   print $fh "<subchar> ";
+   foreach my $c (split(//,$rep))
+    {
+     printf $fh "\\x%02X",ord($c);
+    }
+   print $fh "\n";
+  }
+ my @cmap;
+ output_ucm_page(\@cmap,$h,$h,0);
+ print $fh "#\nCHARMAP\n";
+ foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
+  {
+   print $fh $line;
+  }
+ print $fh "END CHARMAP\n";
+}
+
+use vars qw(
+    $_Enc2xs
+    $_Version
+    $_Inc
+    $_E2X 
+    $_Name
+    $_TableFiles
+    $_Now
+);
+
+sub find_e2x{
+    eval { require File::Find; };
+    my (@inc, %e2x_dir);
+    for my $inc (@INC){
+	push @inc, $inc unless $inc eq '.'; #skip current dir
+    }
+    File::Find::find(
+	     sub {
+		 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+		     $atime,$mtime,$ctime,$blksize,$blocks)
+		     = lstat($_) or return;
+		 -f _ or return;
+		 if (/^.*\.e2x$/o){
+		     no warnings 'once';
+		     $e2x_dir{$File::Find::dir} ||= $mtime;
+		 }
+		 return;
+	     }, @inc);
+    warn join("\n", keys %e2x_dir), "\n";
+    for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){
+	$_E2X = $d;
+	# warn "$_E2X => ", scalar localtime($e2x_dir{$d});
+	return $_E2X;
+    }
+}
+
+sub make_makefile_pl
+{
+    eval { require Encode; };
+    $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n";
+    # our used for variable expanstion
+    $_Enc2xs = $0;
+    $_Version = $VERSION;
+    $_E2X = find_e2x();
+    $_Name = shift;
+    $_TableFiles = join(",", map {qq('$_')} @_);
+    $_Now = scalar localtime();
+
+    eval { require File::Spec; };
+    _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL");
+    _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"),        "$_Name.pm");
+    _print_expand(File::Spec->catfile($_E2X,"_T.e2x"),         "t/$_Name.t");
+    _print_expand(File::Spec->catfile($_E2X,"README.e2x"),     "README");
+    _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"),    "Changes");
+    exit;
+}
+
+use vars qw(
+	    $_ModLines
+	    $_LocalVer
+	    );
+
+sub make_configlocal_pm
+{
+    eval { require Encode; };
+    $@ and die "Unable to require Encode: $@\n";
+    eval { require File::Spec; };
+    # our used for variable expanstion
+    my %in_core = map {$_=>1}('ascii','iso-8859-1','utf8');
+    my %LocalMod = ();
+    for my $d (@INC){
+	my $inc = File::Spec->catfile($d, "Encode");
+	-d $inc or next;
+	opendir my $dh, $inc or die "$inc:$!";
+	warn "Checking $inc...\n";
+	for my $f (grep /\.pm$/o, readdir($dh)){
+	    -f File::Spec->catfile($inc, "$f") or next;
+	    $INC{"Encode/$f"} and next;
+	    warn "require Encode/$f;\n";
+	    eval { require "Encode/$f"; };
+	    $@ and die "Can't require Encode/$f: $@\n";
+	    for my $enc (Encode->encodings()){
+		no warnings 'once';
+		$in_core{$enc} and next;
+		$Encode::Config::ExtModule{$enc} and next;
+		my $mod = "Encode/$f"; 
+		$mod =~ s/\.pm$//o; $mod =~ s,/,::,og;
+		$LocalMod{$enc} ||= $mod;
+	    }
+	}
+    }
+    $_ModLines = "";
+    for my $enc (sort keys %LocalMod){
+	$_ModLines .= 
+	    qq(\$Encode::ExtModule{'$enc'} =\t"$LocalMod{$enc}";\n);
+    }
+    warn $_ModLines;
+    $_LocalVer = _mkversion();
+    $_E2X = find_e2x();
+    $_Inc = $INC{"Encode.pm"}; $_Inc =~ s/\.pm$//o;    
+    _print_expand(File::Spec->catfile($_E2X,"ConfigLocal_PM.e2x"),    
+		  File::Spec->catfile($_Inc,"ConfigLocal.pm"),
+		  1);
+    exit;
+}
+
+sub _mkversion{
+    my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
+    $yyyy += 1900, $mo +=1;
+    return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
+}
+
+sub _print_expand{
+    eval { require File::Basename; };
+    $@ and die "File::Basename needed.  Are you on miniperl?;\nerror: $@\n";
+    File::Basename->import();
+    my ($src, $dst, $clobber) = @_;
+    if (!$clobber and -e $dst){
+	warn "$dst exists. skipping\n";
+	return;
+    }
+    warn "Generating $dst...\n";
+    open my $in, $src or die "$src : $!";
+    if ((my $d = dirname($dst)) ne '.'){
+	-d $d or mkdir $d, 0755 or die  "mkdir $d : $!";
+    }	   
+    open my $out, ">$dst" or die "$!";
+    my $asis = 0;
+    while (<$in>){ 
+	if (/^#### END_OF_HEADER/){
+	    $asis = 1; next;
+	}	  
+	s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
+	print $out $_;
+    }
+}
+__END__
+
+=head1 NAME
+
+enc2xs -- Perl Encode Module Generator
+
+=head1 SYNOPSIS
+
+  enc2xs -[options]
+  enc2xs -M ModName mapfiles...
+  enc2xs -C
+
+=head1 DESCRIPTION
+
+F<enc2xs> builds a Perl extension for use by Encode from either
+Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
+Besides being used internally during the build process of the Encode
+module, you can use F<enc2xs> to add your own encoding to perl.
+No knowledge of XS is necessary.
+
+=head1 Quick Guide
+
+If you want to know as little about Perl as possible but need to
+add a new encoding, just read this chapter and forget the rest.
+
+=over 4
+
+=item 0.
+
+Have a .ucm file ready.  You can get it from somewhere or you can write
+your own from scratch or you can grab one from the Encode distribution
+and customize it.  For the UCM format, see the next Chapter.  In the
+example below, I'll call my theoretical encoding myascii, defined
+in I<my.ucm>.  C<$> is a shell prompt.
+
+  $ ls -F
+  my.ucm
+
+=item 1.
+
+Issue a command as follows;
+
+  $ enc2xs -M My my.ucm
+  generating Makefile.PL
+  generating My.pm
+  generating README
+  generating Changes
+
+Now take a look at your current directory.  It should look like this.
+
+  $ ls -F
+  Makefile.PL   My.pm         my.ucm        t/
+
+The following files were created.
+
+  Makefile.PL - MakeMaker script
+  My.pm       - Encode submodule
+  t/My.t      - test file
+
+=over 4
+
+=item 1.1.
+
+If you want *.ucm installed together with the modules, do as follows;
+
+  $ mkdir Encode
+  $ mv *.ucm Encode
+  $ enc2xs -M My Encode/*ucm
+
+=back
+
+=item 2.
+
+Edit the files generated.  You don't have to if you have no time AND no
+intention to give it to someone else.  But it is a good idea to edit
+the pod and to add more tests.
+
+=item 3.
+
+Now issue a command all Perl Mongers love:
+
+  $ perl Makefile.PL
+  Writing Makefile for Encode::My
+
+=item 4.
+
+Now all you have to do is make.
+
+  $ make
+  cp My.pm blib/lib/Encode/My.pm
+  /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
+    -o encode_t.c -f encode_t.fnm
+  Reading myascii (myascii)
+  Writing compiled form
+  128 bytes in string tables
+  384 bytes (75%) saved spotting duplicates
+  1 bytes (0.775%) saved using substrings
+  ....
+  chmod 644 blib/arch/auto/Encode/My/My.bs
+  $
+
+The time it takes varies depending on how fast your machine is and
+how large your encoding is.  Unless you are working on something big
+like euc-tw, it won't take too long.
+
+=item 5.
+
+You can "make install" already but you should test first.
+
+  $ make test
+  PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
+    -e 'use Test::Harness  qw(&runtests $verbose); \
+    $verbose=0; runtests @ARGV;' t/*.t
+  t/My....ok
+  All tests successful.
+  Files=1, Tests=2,  0 wallclock secs
+   ( 0.09 cusr + 0.01 csys = 0.09 CPU)
+
+=item 6.
+
+If you are content with the test result, just "make install"
+
+=item 7.
+
+If you want to add your encoding to Encode's demand-loading list
+(so you don't have to "use Encode::YourEncoding"), run
+
+  enc2xs -C
+
+to update Encode::ConfigLocal, a module that controls local settings.
+After that, "use Encode;" is enough to load your encodings on demand.
+
+=back
+
+=head1 The Unicode Character Map
+
+Encode uses the Unicode Character Map (UCM) format for source character
+mappings.  This format is used by IBM's ICU package and was adopted
+by Nick Ing-Simmons for use with the Encode module.  Since UCM is
+more flexible than Tcl's Encoding Map and far more user-friendly,
+this is the recommended formet for Encode now.
+
+A UCM file looks like this.
+
+  #
+  # Comments
+  #
+  <code_set_name> "US-ascii" # Required
+  <code_set_alias> "ascii"   # Optional
+  <mb_cur_min> 1             # Required; usually 1
+  <mb_cur_max> 1             # Max. # of bytes/char
+  <subchar> \x3F             # Substitution char
+  #
+  CHARMAP
+  <U0000> \x00 |0 # <control>
+  <U0001> \x01 |0 # <control>
+  <U0002> \x02 |0 # <control>
+  ....
+  <U007C> \x7C |0 # VERTICAL LINE
+  <U007D> \x7D |0 # RIGHT CURLY BRACKET
+  <U007E> \x7E |0 # TILDE
+  <U007F> \x7F |0 # <control>
+  END CHARMAP
+
+=over 4
+
+=item *
+
+Anything that follows C<#> is treated as a comment.
+
+=item *
+
+The header section continues until a line containing the word
+CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
+pair per line.  Strings used as values must be quoted. Barewords are
+treated as numbers.  I<\xXX> represents a byte.
+
+Most of the keywords are self-explanatory. I<subchar> means
+substitution character, not subcharacter.  When you decode a Unicode
+sequence to this encoding but no matching character is found, the byte
+sequence defined here will be used.  For most cases, the value here is
+\x3F; in ASCII, this is a question mark.
+
+=item *
+
+CHARMAP starts the character map section.  Each line has a form as
+follows:
+
+  <UXXXX> \xXX.. |0 # comment
+    ^     ^      ^
+    |     |      +- Fallback flag
+    |     +-------- Encoded byte sequence
+    +-------------- Unicode Character ID in hex
+
+The format is roughly the same as a header section except for the
+fallback flag: | followed by 0..3.   The meaning of the possible
+values is as follows:
+
+=over 4
+
+=item |0 
+
+Round trip safe.  A character decoded to Unicode encodes back to the
+same byte sequence.  Most characters have this flag.
+
+=item |1
+
+Fallback for unicode -> encoding.  When seen, enc2xs adds this
+character for the encode map only.
+
+=item |2 
+
+Skip sub-char mapping should there be no code point.
+
+=item |3 
+
+Fallback for encoding -> unicode.  When seen, enc2xs adds this
+character for the decode map only.
+
+=back
+
+=item *
+
+And finally, END OF CHARMAP ends the section.
+
+=back
+
+When you are manually creating a UCM file, you should copy ascii.ucm
+or an existing encoding which is close to yours, rather than write
+your own from scratch.
+
+When you do so, make sure you leave at least B<U0000> to B<U0020> as
+is, unless your environment is EBCDIC.
+
+B<CAVEAT>: not all features in UCM are implemented.  For example,
+icu:state is not used.  Because of that, you need to write a perl
+module if you want to support algorithmical encodings, notably
+the ISO-2022 series.  Such modules include L<Encode::JP::2022_JP>,
+L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
+
+=head2 Coping with duplicate mappings
+
+When you create a map, you SHOULD make your mappings round-trip safe.
+That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
+$data> stands for all characters that are marked as C<|0>.  Here is
+how to make sure:
+
+=over 4
+
+=item * 
+
+Sort your map in Unicode order.
+
+=item *
+
+When you have a duplicate entry, mark either one with '|1' or '|3'.
+  
+=item * 
+
+And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
+
+=back
+
+Here is an example from big5-eten.
+
+  <U2550> \xF9\xF9 |0
+  <U2550> \xA2\xA4 |3
+
+Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
+this;
+
+  E to U               U to E
+  --------------------------------------
+  \xF9\xF9 => U2550    U2550 => \xF9\xF9
+  \xA2\xA4 => U2550
+ 
+So it is round-trip safe for \xF9\xF9.  But if the line above is upside
+down, here is what happens.
+
+  E to U               U to E
+  --------------------------------------
+  \xA2\xA4 => U2550    U2550 => \xF9\xF9
+  (\xF9\xF9 => U2550 is now overwritten!)
+
+The Encode package comes with F<ucmlint>, a crude but sufficient
+utility to check the integrity of a UCM file.  Check under the
+Encode/bin directory for this.
+
+When in doubt, you can use F<ucmsort>, yet another utility under
+Encode/bin directory.
+
+=head1 Bookmarks
+
+=over 4
+
+=item *
+
+ICU Home Page 
+L<http://oss.software.ibm.com/icu/>
+
+=item *
+
+ICU Character Mapping Tables
+L<http://oss.software.ibm.com/icu/charset/>
+
+=item *
+
+ICU:Conversion Data
+L<http://oss.software.ibm.com/icu/userguide/conversion-data.html>
+
+=back
+
+=head1 SEE ALSO
+
+L<Encode>,
+L<perlmod>,
+L<perlpod>
+
+=cut
+
+# -Q to disable the duplicate codepoint test
+# -S make mapping errors fatal
+# -q to remove comments written to output files
+# -O to enable the (brute force) substring optimiser
+# -o <output> to specify the output file name (else it's the first arg)
+# -f <inlist> to give a file with a list of input files (else use the args)
+# -n <name> to name the encoding (else use the basename of the input file.
+
+With %seen holding array refs:
+
+      865.66 real        28.80 user         8.79 sys
+      7904  maximum resident set size
+      1356  average shared memory size
+     18566  average unshared data size
+       229  average unshared stack size
+     46080  page reclaims
+     33373  page faults
+
+With %seen holding simple scalars:
+
+      342.16 real        27.11 user         3.54 sys
+      8388  maximum resident set size
+      1394  average shared memory size
+     14969  average unshared data size
+       236  average unshared stack size
+     28159  page reclaims
+      9839  page faults
+
+Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
+how %seen is storing things its seen. So it is pathalogically bad on a 16M
+RAM machine, but it's going to help even on modern machines.
+Swapping is bad, m'kay :-)
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/exetype.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/exetype.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/exetype.bat	(revision 19631)
@@ -0,0 +1,124 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+use strict;
+
+# All the IMAGE_* structures are defined in the WINNT.H file
+# of the Microsoft Platform SDK.
+
+my %subsys = (NATIVE    => 1,
+              WINDOWS   => 2,
+              CONSOLE   => 3,
+              POSIX     => 7,
+              WINDOWSCE => 9);
+
+unless (0 < @ARGV && @ARGV < 3) {
+    printf "Usage: $0 exefile [%s]\n", join '|', sort keys %subsys;
+    exit;
+}
+
+$ARGV[1] = uc $ARGV[1] if $ARGV[1];
+unless (@ARGV == 1 || defined $subsys{$ARGV[1]}) {
+    (my $subsys = join(', ', sort keys %subsys)) =~ s/, (\w+)$/ or $1/;
+    print "Invalid subsystem $ARGV[1], please use $subsys\n";
+    exit;
+}
+
+my ($record,$magic,$signature,$offset,$size);
+open EXE, "+< $ARGV[0]" or die "Cannot open $ARGV[0]: $!\n";
+binmode EXE;
+
+# read IMAGE_DOS_HEADER structure
+read EXE, $record, 64;
+($magic,$offset) = unpack "Sx58L", $record;
+
+die "$ARGV[0] is not an MSDOS executable file.\n"
+    unless $magic == 0x5a4d; # "MZ"
+
+# read signature, IMAGE_FILE_HEADER and first WORD of IMAGE_OPTIONAL_HEADER
+seek EXE, $offset, 0;
+read EXE, $record, 4+20+2;
+($signature,$size,$magic) = unpack "Lx16Sx2S", $record;
+
+die "PE header not found" unless $signature == 0x4550; # "PE\0\0"
+
+die "Optional header is neither in NT32 nor in NT64 format"
+    unless ($size == 224 && $magic == 0x10b) || # IMAGE_NT_OPTIONAL_HDR32_MAGIC
+           ($size == 240 && $magic == 0x20b);   # IMAGE_NT_OPTIONAL_HDR64_MAGIC
+
+# Offset 68 in the IMAGE_OPTIONAL_HEADER(32|64) is the 16 bit subsystem code
+seek EXE, $offset+4+20+68, 0;
+if (@ARGV == 1) {
+    read EXE, $record, 2;
+    my ($subsys) = unpack "S", $record;
+    $subsys = {reverse %subsys}->{$subsys} || "UNKNOWN($subsys)";
+    print "$ARGV[0] uses the $subsys subsystem.\n";
+}
+else {
+    print EXE pack "S", $subsys{$ARGV[1]};
+}
+close EXE;
+__END__
+
+=head1 NAME
+
+exetype - Change executable subsystem type between "Console" and "Windows"
+
+=head1 SYNOPSIS
+
+	C:\perl\bin> copy perl.exe guiperl.exe
+	C:\perl\bin> exetype guiperl.exe windows
+
+=head1 DESCRIPTION
+
+This program edits an executable file to indicate which subsystem the
+operating system must invoke for execution.
+
+You can specify any of the following subsystems:
+
+=over
+
+=item CONSOLE
+
+The CONSOLE subsystem handles a Win32 character-mode application that
+use a console supplied by the operating system.
+
+=item WINDOWS
+
+The WINDOWS subsystem handles an application that does not require a
+console and creates its own windows, if required.
+
+=item NATIVE
+
+The NATIVE subsystem handles a Windows NT device driver.
+
+=item WINDOWSCE
+
+The WINDOWSCE subsystem handles Windows CE consumer electronics
+applications.
+
+=item POSIX
+
+The POSIX subsystem handles a POSIX application in Windows NT.
+
+=back
+
+=head1 AUTHOR
+
+Jan Dubois <jand@activestate.com>
+
+=cut
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/find2perl.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/find2perl.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/find2perl.bat	(revision 19631)
@@ -0,0 +1,909 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+      if $running_under_some_shell;
+(my $perlpath = <<'/../') =~ s/\s*\z//;
+c:\shaoqunWu\perl\bin\perl.exe
+/../
+use strict;
+use vars qw/$statdone/;
+use File::Spec::Functions 'curdir';
+my $startperl = "#! $perlpath -w";
+
+#
+# Modified September 26, 1993 to provide proper handling of years after 1999
+#   Tom Link <tml+@pitt.edu>
+#   University of Pittsburgh
+#
+# Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
+#  Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au>
+#  University of Adelaide, Adelaide, South Australia
+#
+# Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage
+#   Ken Pizzini <ken@halcyon.com>
+#
+# Modified 2000-01-28 to use the 'follow' option of File::Find
+
+sub tab ();
+sub n ($$);
+sub fileglob_to_re ($);
+sub quote ($);
+
+my @roots = ();
+while ($ARGV[0] =~ /^[^-!(]/) {
+    push(@roots, shift);
+}
+@roots = (curdir()) unless @roots;
+for (@roots) { $_ = quote($_) }
+my $roots = join(', ', @roots);
+
+my $find = "find";
+my $indent_depth = 1;
+my $stat = 'lstat';
+my $decl = '';
+my $flushall = '';
+my $initfile = '';
+my $initnewer = '';
+my $out = '';
+my $declaresubs = "sub wanted;\n";
+my %init = ();
+my ($follow_in_effect,$Skip_And) = (0,0);
+my $print_needed = 1;
+
+while (@ARGV) {
+    $_ = shift;
+    s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
+    if ($_ eq '(') {
+        $out .= tab . "(\n";
+        $indent_depth++;
+        next;
+    } elsif ($_ eq ')') {
+        --$indent_depth;
+        $out .= tab . ")";
+    } elsif ($_ eq 'follow') {
+        $follow_in_effect= 1;
+        $stat = 'stat';
+        $Skip_And= 1;
+    } elsif ($_ eq '!') {
+        $out .= tab . "!";
+        next;
+    } elsif (/^(i)?name$/) {
+        $out .= tab . '/' . fileglob_to_re(shift) . "/s$1";
+    } elsif (/^(i)?path$/) {
+        $out .= tab . '$File::Find::name =~ /' . fileglob_to_re(shift) . "/s$1";
+    } elsif ($_ eq 'perm') {
+        my $onum = shift;
+        $onum =~ /^-?[0-7]+$/
+            || die "Malformed -perm argument: $onum\n";
+        $out .= tab;
+        if ($onum =~ s/^-//) {
+            $onum = sprintf("0%o", oct($onum) & 07777);
+            $out .= "((\$mode & $onum) == $onum)";
+        } else {
+            $onum =~ s/^0*/0/;
+            $out .= "((\$mode & 0777) == $onum)";
+        }
+    } elsif ($_ eq 'type') {
+        (my $filetest = shift) =~ tr/s/S/;
+        $out .= tab . "-$filetest _";
+    } elsif ($_ eq 'print') {
+        $out .= tab . 'print("$name\n")';
+	$print_needed = 0;
+    } elsif ($_ eq 'print0') {
+        $out .= tab . 'print("$name\0")';
+	$print_needed = 0;
+    } elsif ($_ eq 'fstype') {
+        my $type = shift;
+        $out .= tab;
+        if ($type eq 'nfs') {
+            $out .= '($dev < 0)';
+        } else {
+            $out .= '($dev >= 0)'; #XXX
+        }
+    } elsif ($_ eq 'user') {
+        my $uname = shift;
+        $out .= tab . "(\$uid == \$uid{'$uname'})";
+        $init{user} = 1;
+    } elsif ($_ eq 'group') {
+        my $gname = shift;
+        $out .= tab . "(\$gid == \$gid{'$gname'})";
+        $init{group} = 1;
+    } elsif ($_ eq 'nouser') {
+        $out .= tab . '!exists $uid{$uid}';
+        $init{user} = 1;
+    } elsif ($_ eq 'nogroup') {
+        $out .= tab . '!exists $gid{$gid}';
+        $init{group} = 1;
+    } elsif ($_ eq 'links') {
+        $out .= tab . n('$nlink', shift);
+    } elsif ($_ eq 'inum') {
+        $out .= tab . n('$ino', shift);
+    } elsif ($_ eq 'size') {
+        $_ = shift;
+        my $n = 'int(((-s _) + 511) / 512)';
+        if (s/c\z//) {
+            $n = 'int(-s _)';
+        } elsif (s/k\z//) {
+            $n = 'int(((-s _) + 1023) / 1024)';
+        }
+        $out .= tab . n($n, $_);
+    } elsif ($_ eq 'atime') {
+        $out .= tab . n('int(-A _)', shift);
+    } elsif ($_ eq 'mtime') {
+        $out .= tab . n('int(-M _)', shift);
+    } elsif ($_ eq 'ctime') {
+        $out .= tab . n('int(-C _)', shift);
+    } elsif ($_ eq 'exec') {
+        my @cmd = ();
+        while (@ARGV && $ARGV[0] ne ';')
+            { push(@cmd, shift) }
+        shift;
+        $out .= tab;
+        if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
+                && $cmd[$#cmd] eq '{}'
+                && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
+            if (@cmd == 2) {
+                $out .= '(unlink($_) || warn "$name: $!\n")';
+            } elsif (!@ARGV) {
+                $out .= 'unlink($_)';
+            } else {
+                $out .= '(unlink($_) || 1)';
+            }
+        } else {
+            for (@cmd)
+                { s/'/\\'/g }
+            { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
+            $declaresubs .= "sub doexec (\$\@);\n";
+            $init{doexec} = 1;
+        }
+	$print_needed = 0;
+    } elsif ($_ eq 'ok') {
+        my @cmd = ();
+        while (@ARGV && $ARGV[0] ne ';')
+            { push(@cmd, shift) }
+        shift;
+        $out .= tab;
+        for (@cmd)
+            { s/'/\\'/g }
+        { local $" = "','"; $out .= "doexec(1, '@cmd')"; }
+        $declaresubs .= "sub doexec (\$\@);\n";
+        $init{doexec} = 1;
+	$print_needed = 0;
+    } elsif ($_ eq 'prune') {
+        $out .= tab . '($File::Find::prune = 1)';
+    } elsif ($_ eq 'xdev') {
+        $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
+;
+    } elsif ($_ eq 'newer') {
+        my $file = shift;
+        my $newername = 'AGE_OF' . $file;
+        $newername =~ s/\W/_/g;
+        $newername = '$' . $newername;
+        $out .= tab . "(-M _ < $newername)";
+        $initnewer .= "my $newername = -M " . quote($file) . ";\n";
+    } elsif ($_ eq 'eval') {
+        my $prog = shift;
+        $prog =~ s/'/\\'/g;
+        $out .= tab . "eval {$prog}";
+	$print_needed = 0;
+    } elsif ($_ eq 'depth') {
+        $find = 'finddepth';
+        next;
+    } elsif ($_ eq 'ls') {
+        $out .= tab . "ls";
+        $declaresubs .= "sub ls ();\n";
+        $init{ls} = 1;
+	$print_needed = 0;
+    } elsif ($_ eq 'tar') {
+        die "-tar must have a filename argument\n" unless @ARGV;
+        my $file = shift;
+        my $fh = 'FH' . $file;
+        $fh =~ s/\W/_/g;
+        $out .= tab . "tar(*$fh, \$name)";
+        $flushall .= "tflushall;\n";
+        $declaresubs .= "sub tar;\nsub tflushall ();\n";
+        $initfile .= "open($fh, " . quote('> ' . $file) .
+                     qq{) || die "Can't open $fh: \$!\\n";\n};
+        $init{tar} = 1;
+    } elsif (/^(n?)cpio\z/) {
+        die "-$_ must have a filename argument\n" unless @ARGV;
+        my $file = shift;
+        my $fh = 'FH' . $file;
+        $fh =~ s/\W/_/g;
+        $out .= tab . "cpio(*$fh, \$name, '$1')";
+        $find = 'finddepth';
+        $flushall .= "cflushall;\n";
+        $declaresubs .= "sub cpio;\nsub cflushall ();\n";
+        $initfile .= "open($fh, " . quote('> ' . $file) .
+                     qq{) || die "Can't open $fh: \$!\\n";\n};
+        $init{cpio} = 1;
+    } else {
+        die "Unrecognized switch: -$_\n";
+    }
+
+    if (@ARGV) {
+        if ($ARGV[0] eq '-o') {
+            { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
+            $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
+            $init{saw_or} = 1;
+            shift;
+        } else {
+            $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
+            $out .= "\n";
+            shift if $ARGV[0] eq '-a';
+        }
+    }
+}
+
+if ($print_needed) {
+    my $t = tab;
+    if ($t !~ /&&\s*$/) { $t .= '&& ' }
+    $out .= "\n" . $t . 'print("$name\n")';
+}
+
+
+print <<"END";
+$startperl
+    eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+        if 0; #\$running_under_some_shell
+
+use strict;
+use File::Find ();
+
+# Set the variable \$File::Find::dont_use_nlink if you're using AFS,
+# since AFS cheats.
+
+# for the convenience of &wanted calls, including -eval statements:
+use vars qw/*name *dir *prune/;
+*name   = *File::Find::name;
+*dir    = *File::Find::dir;
+*prune  = *File::Find::prune;
+
+$declaresubs
+
+END
+
+if (exists $init{doexec}) {
+    print <<'END';
+use Cwd ();
+my $cwd = Cwd::cwd();
+
+END
+}  
+
+if (exists $init{ls}) {
+    print <<'END';
+my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
+my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+
+END
+}
+
+if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
+    print "my (%uid, %user);\n";
+    print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
+    print '    $uid{$name} = $uid{$uid} = $uid;', "\n"
+        if exists $init{user};
+    print '    $user{$uid} = $name unless exists $user{$uid};', "\n"
+        if exists $init{ls} || exists $init{tar};
+    print "}\n\n";
+}
+
+if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
+    print "my (%gid, %group);\n";
+    print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
+    print '    $gid{$name} = $gid{$gid} = $gid;', "\n"
+        if exists $init{group};
+    print '    $group{$gid} = $name unless exists $group{$gid};', "\n"
+        if exists $init{ls} || exists $init{tar};
+    print "}\n\n";
+}
+
+print $initnewer, "\n" if $initnewer ne '';
+print $initfile, "\n" if $initfile ne '';
+$flushall .= "exit;\n";
+if (exists $init{declarestat}) {
+    $out = <<'END' . $out;
+    my ($dev,$ino,$mode,$nlink,$uid,$gid);
+
+END
+}
+
+if ( $follow_in_effect ) {
+$out =~ s/lstat\(\$_\)/lstat(_)/;
+print <<"END";
+$decl
+# Traverse desired filesystems
+File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
+$flushall
+
+sub wanted {
+$out;
+}
+
+END
+} else {
+print <<"END";
+$decl
+# Traverse desired filesystems
+File::Find::$find({wanted => \\&wanted}, $roots);
+$flushall
+
+sub wanted {
+$out;
+}
+
+END
+}
+
+if (exists $init{doexec}) {
+    print <<'END';
+
+sub doexec ($@) {
+    my $ok = shift;
+    my @command = @_; # copy so we don't try to s/// aliases to constants
+    for my $word (@command)
+        { $word =~ s#{}#$name#g }
+    if ($ok) {
+        my $old = select(STDOUT);
+        $| = 1;
+        print "@command";
+        select($old);
+        return 0 unless <STDIN> =~ /^y/;
+    }
+    chdir $cwd; #sigh
+    system @command;
+    chdir $File::Find::dir;
+    return !$?;
+}
+
+END
+}
+
+if (exists $init{ls}) {
+    print <<'INTRO', <<"SUB", <<'END';
+
+sub sizemm {
+    my $rdev = shift;
+    sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
+}
+
+sub ls () {
+    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+        \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+    my $pname = $name;
+
+    $blocks
+        or $blocks = int(($size + 1023) / 1024);
+
+    my $perms = $rwx[$mode & 7];
+    $mode >>= 3;
+    $perms = $rwx[$mode & 7] . $perms;
+    $mode >>= 3;
+    $perms = $rwx[$mode & 7] . $perms;
+    substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
+    substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
+    substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
+    if    (-f _) { $perms = '-' . $perms; }
+    elsif (-d _) { $perms = 'd' . $perms; }
+    elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
+    elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
+    elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
+    elsif (-p _) { $perms = 'p' . $perms; }
+    elsif (-S _) { $perms = 's' . $perms; }
+    else         { $perms = '?' . $perms; }
+
+    my $user = $user{$uid} || $uid;
+    my $group = $group{$gid} || $gid;
+
+    my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
+    if (-M _ > 365.25 / 2) {
+        $timeyear += 1900;
+    } else {
+        $timeyear = sprintf("%02d:%02d", $hour, $min);
+    }
+
+    printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
+            $ino,
+                 $blocks,
+                      $perms,
+                            $nlink,
+                                $user,
+                                     $group,
+                                          $size,
+                                              $moname[$mon],
+                                                 $mday,
+                                                     $timeyear,
+                                                         $pname;
+    1;
+}
+
+END
+}
+
+
+if (exists $init{cpio} || exists $init{tar}) {
+print <<'END';
+
+my %blocks = ();
+
+sub flush {
+    my ($fh, $varref, $blksz) = @_;
+
+    while (length($$varref) >= $blksz) {
+        no strict qw/refs/;
+        syswrite($fh, $$varref, $blksz);
+        substr($$varref, 0, $blksz) = '';
+        ++$blocks{$fh};
+    }
+}
+
+END
+}
+
+
+if (exists $init{cpio}) {
+    print <<'INTRO', <<"SUB", <<'END';
+
+my %cpout = ();
+my %nc = ();
+
+sub cpio {
+    my ($fh, $fname, $nc) = @_;
+    my $text = '';
+    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+        $atime,$mtime,$ctime,$blksize,$blocks);
+    local (*IN);
+
+    if ( ! defined $fname ) {
+        $fname = 'TRAILER!!!';
+        ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+          $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
+    } else {
+        ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+          \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+        if (-f _) {
+            open(IN, "./$_\0") || do {
+                warn "Couldn't open $fname: $!\n";
+                return;
+            }
+        } else {
+            $text = readlink($_);
+            $size = 0 unless defined $text;
+        }
+    }
+
+    $fname =~ s#^\./##;
+    $nc{$fh} = $nc;
+    if ($nc eq 'n') {
+        $cpout{$fh} .=
+          sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
+            070707,
+            $dev & 0777777,
+            $ino & 0777777,
+            $mode & 0777777,
+            $uid & 0777777,
+            $gid & 0777777,
+            $nlink & 0777777,
+            $rdev & 0177777,
+            $mtime,
+            length($fname)+1,
+            $size,
+            $fname);
+    } else {
+        $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
+        $cpout{$fh} .= pack("SSSSSSSSLSLa*",
+            070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
+            length($fname)+1, $size,
+            $fname . (length($fname) & 1 ? "\0" : "\0\0"));
+    }
+
+    if ($text ne '') {
+        $cpout{$fh} .= $text;
+    } elsif ($size) {
+        my $l;
+        flush($fh, \$cpout{$fh}, 5120)
+            while ($l = length($cpout{$fh})) >= 5120;
+        while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
+            flush($fh, \$cpout{$fh}, 5120);
+            $l = length($cpout{$fh});
+        }
+        close IN;
+    }
+}
+
+sub cflushall () {
+    for my $fh (keys %cpout) {
+        cpio($fh, undef, $nc{$fh});
+        $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
+        flush($fh, \$cpout{$fh}, 5120);
+        print $blocks{$fh} * 10, " blocks\n";
+    }
+}
+
+END
+}
+
+if (exists $init{tar}) {
+    print <<'INTRO', <<"SUB", <<'END';
+
+my %tarout = ();
+my %linkseen = ();
+
+sub tar {
+    my ($fh, $fname) = @_;
+    my $prefix = '';
+    my $typeflag = '0';
+    my $linkname;
+    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+        \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+    local (*IN);
+
+    if ($nlink > 1) {
+        if ($linkname = $linkseen{$fh, $dev, $ino}) {
+            if (length($linkname) > 100) {
+                warn "$0: omitting file with linkname ",
+                     "too long for tar output: $linkname\n";
+                return;
+            }
+            $typeflag = '1';
+            $size = 0;
+        } else {
+            $linkseen{$fh, $dev, $ino} = $fname;
+        }
+    }
+    if ($typeflag eq '0') {
+        if (-f _) {
+            open(IN, "./$_\0") || do {
+                warn "Couldn't open $fname: $!\n";
+                return;
+            }
+        } else {
+            $linkname = readlink($_);
+            if (defined $linkname) { $typeflag = '2' }
+            elsif (-c _) { $typeflag = '3' }
+            elsif (-b _) { $typeflag = '4' }
+            elsif (-d _) { $typeflag = '5' }
+            elsif (-p _) { $typeflag = '6' }
+        }
+    }
+
+    if (length($fname) > 100) {
+        ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
+        if (!defined($fname) || length($prefix) > 155) {
+            warn "$0: omitting file with name too long for tar output: ",
+                 $fname, "\n";
+            return;
+        }
+    }
+
+    $size = 0 if $typeflag ne '0';
+    my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
+                        $fname,
+                        sprintf("%7o ", $mode &    0777),
+                        sprintf("%7o ", $uid  & 0777777),
+                        sprintf("%7o ", $gid  & 0777777),
+                        sprintf("%11o ", $size),
+                        sprintf("%11o ", $mtime),
+                        ' 'x8,
+                        $typeflag,
+                        defined $linkname ? $linkname : '',
+                        "ustar\0",
+                        "00",
+                        $user{$uid},
+                        $group{$gid},
+                        ($rdev >> 8) & 0xff,
+                        $rdev & 0xff,
+                        $prefix,
+                     );
+    substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
+    my $l = length($header) % 512;
+    $tarout{$fh} .= $header;
+    $tarout{$fh} .= "\0" x (512 - $l) if $l;
+
+    if ($size) {
+        flush($fh, \$tarout{$fh}, 10240)
+            while ($l = length($tarout{$fh})) >= 10240;
+        while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
+            my $slop = length($tarout{$fh}) % 512;
+            $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
+            flush($fh, \$tarout{$fh}, 10240);
+            $l = length($tarout{$fh});
+        }
+        close IN;
+    }
+}
+
+sub tflushall () {
+    my $len;
+    for my $fh (keys %tarout) {
+        $len = 10240 - length($tarout{$fh});
+        $len += 10240 if $len < 1024;
+        $tarout{$fh} .= "\0" x $len;
+        flush($fh, \$tarout{$fh}, 10240);
+    }
+}
+
+END
+}
+
+exit;
+
+############################################################################
+
+sub tab () {
+    my $tabstring;
+
+    $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
+    if (!$statdone) {
+        if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
+            $init{delayedstat} = 1;
+        } else {
+            my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
+                         . $stat . '($_))';
+            if (exists $init{saw_or}) {
+                $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
+            } else {
+                $tabstring .= "$statcall &&\n" . $tabstring;
+            }
+            $statdone = 1;
+            $init{declarestat} = 1;
+        }
+    }
+    $tabstring =~ s/^\s+/ / if $out =~ /!$/;
+    $tabstring;
+}
+
+sub fileglob_to_re ($) {
+    my $x = shift;
+    $x =~ s#([./^\$()+])#\\$1#g;
+    $x =~ s#([?*])#.$1#g;
+    "^$x\\z";
+}
+
+sub n ($$) {
+    my ($pre, $n) = @_;
+    $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
+    $n =~ s/ 0*(\d)/ $1/;
+    "($pre $n)";
+}
+
+sub quote ($) {
+    my $string = shift;
+    $string =~ s/\\/\\\\/g;
+    $string =~ s/'/\\'/g;
+    "'$string'";
+}
+
+__END__
+
+=head1 NAME
+
+find2perl - translate find command lines to Perl code
+
+=head1 SYNOPSIS
+
+	find2perl [paths] [predicates] | perl
+
+=head1 DESCRIPTION
+
+find2perl is a little translator to convert find command lines to
+equivalent Perl code.  The resulting code is typically faster than
+running find itself.
+
+"paths" are a set of paths where find2perl will start its searches and
+"predicates" are taken from the following list.
+
+=over 4
+
+=item C<! PREDICATE>
+
+Negate the sense of the following predicate.  The C<!> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<( PREDICATES )>
+
+Group the given PREDICATES.  The parentheses must be passed as distinct
+arguments, so they may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<PREDICATE1 PREDICATE2>
+
+True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
+evaluated if PREDICATE1 is false.
+
+=item C<PREDICATE1 -o PREDICATE2>
+
+True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
+not evaluated if PREDICATE1 is true.
+
+=item C<-follow>
+
+Follow (dereference) symlinks.  The checking of file attributes depends
+on the position of the C<-follow> option. If it precedes the file
+check option, an C<stat> is done which means the file check applies to the
+file the symbolic link is pointing to. If C<-follow> option follows the
+file check option, this now applies to the symbolic link itself, i.e.
+an C<lstat> is done.
+
+=item C<-depth>
+
+Change directory traversal algorithm from breadth-first to depth-first.
+
+=item C<-prune>
+
+Do not descend into the directory currently matched.
+
+=item C<-xdev>
+
+Do not traverse mount points (prunes search at mount-point directories).
+
+=item C<-name GLOB>
+
+File name matches specified GLOB wildcard pattern.  GLOB may need to be
+quoted to avoid interpretation by the shell (just as with using
+C<find(1)>).
+
+=item C<-iname GLOB>
+
+Like C<-name>, but the match is case insensitive.
+
+=item C<-path GLOB>
+
+Path name matches specified GLOB wildcard pattern.
+
+=item C<-ipath GLOB>
+
+Like C<-path>, but the match is case insensitive.
+
+=item C<-perm PERM>
+
+Low-order 9 bits of permission match octal value PERM.
+
+=item C<-perm -PERM>
+
+The bits specified in PERM are all set in file's permissions.
+
+=item C<-type X>
+
+The file's type matches perl's C<-X> operator.
+
+=item C<-fstype TYPE>
+
+Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
+is implemented).
+
+=item C<-user USER>
+
+True if USER is owner of file.
+
+=item C<-group GROUP>
+
+True if file's group is GROUP.
+
+=item C<-nouser>
+
+True if file's owner is not in password database.
+
+=item C<-nogroup>
+
+True if file's group is not in group database.
+
+=item C<-inum INUM>
+
+True file's inode number is INUM.
+
+=item C<-links N>
+
+True if (hard) link count of file matches N (see below).
+
+=item C<-size N>
+
+True if file's size matches N (see below) N is normally counted in
+512-byte blocks, but a suffix of "c" specifies that size should be
+counted in characters (bytes) and a suffix of "k" specifes that
+size should be counted in 1024-byte blocks.
+
+=item C<-atime N>
+
+True if last-access time of file matches N (measured in days) (see
+below).
+
+=item C<-ctime N>
+
+True if last-changed time of file's inode matches N (measured in days,
+see below).
+
+=item C<-mtime N>
+
+True if last-modified time of file matches N (measured in days, see below).
+
+=item C<-newer FILE>
+
+True if last-modified time of file matches N.
+
+=item C<-print>
+
+Print out path of file (always true). If none of C<-exec>, C<-ls>,
+C<-print0>, or C<-ok> is specified, then C<-print> will be added
+implicitly.
+
+=item C<-print0>
+
+Like -print, but terminates with \0 instead of \n.
+
+=item C<-exec OPTIONS ;>
+
+exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
+OPTIONS will first be substituted with the path of the current
+file.  Note that the command "rm" has been special-cased to use perl's
+unlink() function instead (as an optimization).  The C<;> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<-ok OPTIONS ;>
+
+Like -exec, but first prompts user; if user's response does not begin
+with a y, skip the exec.  The C<;> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<-eval EXPR>
+
+Has the perl script eval() the EXPR.  
+
+=item C<-ls>
+
+Simulates C<-exec ls -dils {} ;>
+
+=item C<-tar FILE>
+
+Adds current output to tar-format FILE.
+
+=item C<-cpio FILE>
+
+Adds current output to old-style cpio-format FILE.
+
+=item C<-ncpio FILE>
+
+Adds current output to "new"-style cpio-format FILE.
+
+=back
+
+Predicates which take a numeric argument N can come in three forms:
+
+   * N is prefixed with a +: match values greater than N
+   * N is prefixed with a -: match values less than N
+   * N is not prefixed with either + or -: match only values equal to N
+
+=head1 SEE ALSO
+
+find
+
+=cut
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/h2ph.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/h2ph.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/h2ph.bat	(revision 19631)
@@ -0,0 +1,941 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if $running_under_some_shell;
+
+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;
+@isatype{@isatype} = (1) x @isatype;
+my $inif = 0;
+my %Is_converted;
+my %bad_file = ();
+
+@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, $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 'redefine';\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:
+		    $new = reindent($new);
+		    $args = reindent($args);
+		    if ($t ne '') {
+			$new =~ s/(['\\])/\\$1/g;   #']);
+			if ($opt_h) {
+			    print OUT $t,
+                            "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t    ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
+                            $eval_index++;
+			} else {
+			    print OUT $t,
+                            "eval 'sub $name $proto\{\n$t    ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
+			}
+		    } else {
+                      print OUT "unless(defined(\&$name)) {\n    sub $name $proto\{\n\t${args}eval q($new);\n    }\n}\n";
+		    }
+		    %curargs = ();
+		} else {
+		    s/^\s+//;
+		    expr();
+		    $new = 1 if $new eq '';
+		    $new = reindent($new);
+		    $args = reindent($args);
+		    if ($t ne '') {
+			$new =~ s/(['\\])/\\$1/g;        #']);
+
+			if ($opt_h) {
+			    print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+			    $eval_index++;
+			} else {
+			    print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+			}
+		    } else {
+		    	# Shunt around such directives as `#define FOO FOO':
+		    	next if " \&$name" eq $new;
+
+                      print OUT $t,"unless(defined(\&$name)) {\n    sub $name () {\t",$new,";}\n}\n";
+		    }
+		}
+	    } elsif (/^(include|import|include_next)\s*[<\"](.*)[>\"]/) {
+                $incl_type = $1;
+                $incl = $2;
+                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/;
+		    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)
+	    goto EMIT;
+	}
+    }
+    $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 expr {
+    $new = '"(assembly code)"' and return if /\b__asm__\b/; # freak out.
+    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 "errorneus" 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 && $new !~ /defined\s*\($/) {
+		    $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
+		} 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+<(.*?)>/) {
+                push(@ARGV, $1) unless $Is_converted{$1};
+            }
+        }
+    close HEADER;
+}
+
+
+# Determine include directories; $Config{usrinc} should be enough for (all
+# non-GCC?) C compilers, but gcc uses an additional include directory.
+sub inc_dirs
+{
+    my $from_gcc    = `LC_ALL=C $Config{cc} -v 2>&1`;
+    if( !( $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s ) )
+    { # gcc-4+ :
+       $from_gcc   = `LC_ALL=C $Config{cc} -print-search-dirs 2>&1`;
+       if ( !($from_gcc =~ s/^install:\s*([^\s]+[^\s\/])([\s\/]*).*$/$1\/include/s) )
+       {
+           $from_gcc = '';
+       };
+    };
+    length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
+}
+
+
+# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
+# version of h2ph.
+sub build_preamble_if_necessary
+{
+    # Increment $VERSION every time this function is modified:
+    my $VERSION     = 2;
+    my $preamble    = "$Dest_dir/_h2ph_pre.ph";
+
+    # Can we skip building the preamble file?
+    if (-r $preamble) {
+        # Extract version number from first line of preamble:
+        open  PREAMBLE, $preamble or die "Cannot open $preamble:  $!";
+            my $line = <PREAMBLE>;
+            $line =~ /(\b\d+\b)/;
+        close PREAMBLE            or die "Cannot close $preamble:  $!";
+
+        # Don't build preamble if a compatible preamble exists:
+        return if $1 == $VERSION;
+    }
+
+    my (%define) = _extract_cc_defines();
+
+    open  PREAMBLE, ">$preamble" or die "Cannot open $preamble:  $!";
+        print PREAMBLE "# This file was created by h2ph version $VERSION\n";
+
+        foreach (sort keys %define) {
+            if ($opt_D) {
+                print PREAMBLE "# $_=$define{$_}\n";
+            }
+
+            if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
+                print PREAMBLE
+                    "unless (defined &$_) { sub $_() { $1 } }\n\n";
+            } elsif ($define{$_} =~ /^\w+$/) {
+                print PREAMBLE
+                    "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
+            } else {
+                print PREAMBLE
+                    "unless (defined &$_) { sub $_() { \"",
+                    quotemeta($define{$_}), "\" } }\n\n";
+            }
+        }
+    close PREAMBLE               or die "Cannot close $preamble:  $!";
+}
+
+
+# %Config contains information on macros that are pre-defined by the
+# system's compiler.  We need this information to make the .ph files
+# function with perl as the .h files do with cc.
+sub _extract_cc_defines
+{
+    my %define;
+    my $allsymbols  = join " ",
+        @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
+
+    # Split compiler pre-definitions into `key=value' pairs:
+    foreach (split /\s+/, $allsymbols) {
+        /(.+?)=(.+)/ and $define{$1} = $2;
+
+        if ($opt_D) {
+            print STDERR "$_:  $1 -> $2\n";
+        }
+    }
+
+    return %define;
+}
+
+
+1;
+
+##############################################################################
+__END__
+
+=head1 NAME
+
+h2ph - convert .h C header files to .ph Perl header files
+
+=head1 SYNOPSIS
+
+B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
+
+=head1 DESCRIPTION
+
+I<h2ph>
+converts any C header files specified to the corresponding Perl header file
+format.
+It is most easily run while in /usr/include:
+
+	cd /usr/include; h2ph * sys/*
+
+or
+
+	cd /usr/include; h2ph * 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{'installsitsearch'}>).
+
+=item -r
+
+Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
+on all files in those directories (and their subdirectories, etc.).  B<-r>
+and B<-a> are mutually exclusive.
+
+=item -a
+
+Run automagically; convert B<headerfiles>, as well as any B<.h> files
+which they include.  This option will search for B<.h> files in all
+directories which your C compiler ordinarily uses.  B<-a> and B<-r> are
+mutually exclusive.
+
+=item -l
+
+Symbolic links will be replicated in the destination directory.  If B<-l>
+is not specified, then links are skipped over.
+
+=item -h
+
+Put ``hints'' in the .ph files which will help in locating problems with
+I<h2ph>.  In those cases when you B<require> a B<.ph> file containing syntax
+errors, instead of the cryptic
+
+	[ some error condition ] at (eval mmm) line nnn
+
+you will see the slightly more helpful
+
+	[ some error condition ] at filename.ph line nnn
+
+However, the B<.ph> files almost double in size when built using B<-h>.
+
+=item -D
+
+Include the code from the B<.h> file as a comment in the B<.ph> file.
+This is primarily used for debugging I<h2ph>.
+
+=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
+
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/h2xs.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/h2xs.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/h2xs.bat	(revision 19631)
@@ -0,0 +1,2190 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if $running_under_some_shell;
+
+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.
+
+=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 templates for a module which is not
+XS-based.  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.7.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 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 compatibile 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 =~ /^\d+\.\d+\.\d+/ ||
+    usage "You must provide the backwards compatibility version in X.Y.Z form. "
+          .  "(i.e. 5.5.0)\n";
+    my ($maj,$min,$sub) = split(/\./,$opt_b,3);
+    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 =
+	    $sub ? sprintf("%d.%03d%03d",$maj,$min,$sub) :
+		   sprintf("%d.%03d",    $maj,$min);
+    }
+} 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+$//;
+	    # 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' or 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;
+
+	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) {
+                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}++;
+            }
+        } # 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 = new C::Scan '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 )(?:@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_names = sort keys %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@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";
+#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_names,
+                 );
+  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 exersizes the following two methods, and an additional class
+#C<$name>, the internal representation of which is a reference to a
+#packed string with the C structure.  Keep in mind that \$buffer should
+#better survive longer than \$obj.
+#
+#=over
+#
+#=item C<\$object_of_type_$name-E<gt>_to_ptr()>
+#
+#Converts an object of type C<$name> to an object of type C<$ptrname>.
+#
+#=item C<$name-E<gt>new()>
+#
+#Creates an empty object of type C<$name>.  The corresponding packed
+#string is zeroed out.
+#
+#=item C<$methods>
+#
+#return the current value of the corresponding element if called
+#without additional arguments.  Set the element to the supplied value
+#(and return the new value) if called with an additional argument.
+#
+#Applicable to objects of type C<$ptrname>.
+#
+#=back
+#
+EOF
+  $pod =~ s/^\#//gm;
+  return $pod;
+}
+
+# Should be called before any actual call to normalize_type().
+sub get_typemap {
+  # We do not want to read ./typemap by obvios reasons.
+  my @tm =  qw(../../../typemap ../../typemap ../typemap);
+  my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
+  unshift @tm, $stdtypemap;
+  my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
+
+  # Start with useful default values
+  $typemap{float} = 'T_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 heuristical only
+  my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
+  my $ignore_mods
+    = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
+  if ($do_keep_deep_const) {	# Keep different compiled /RExen/o separately!
+    $type =~ s/$ignore_mods//go;
+  }
+  else {
+    $type =~ s/$ignore_mods//go;
+  }
+  $type =~ s/([^\s\w])/ $1 /g;
+  $type =~ s/\s+$//;
+  $type =~ s/^\s+//;
+  $type =~ s/\s+/ /g;
+  $type =~ s/\* (?=\*)/*/g;
+  $type =~ s/\. \. \./.../g;
+  $type =~ s/ ,/,/g;
+  $types_seen{$type}++
+    unless $type eq '...' or $type eq 'void' or $std_types{$type};
+  $type;
+}
+
+my $need_opaque;
+
+sub assign_typemap_entry {
+  my $type = shift;
+  my $otype = $type;
+  my $entry;
+  if ($tmask and $type =~ /$tmask/) {
+    print "Type $type matches -o mask\n" if $opt_d;
+    $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+  }
+  elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+    $type = normalize_type $type;
+    print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
+    $entry = assign_typemap_entry($type);
+  }
+  # 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.00702 and $new_test )
+{
+  $prereq_pm .= q%'Test::More'  =>  0, %;
+}
+
+if ( $compat_version < 5.00600 and !$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
+    PREREQ_PM         => {$prereq_pm}, # e.g., Module::Name => 1.1
+    (\$] >= 5.005 ?     ## Add these new keywords supported since 5.005
+      (ABSTRACT_FROM  => '$modpmname', # retrieve abstract from module
+       AUTHOR         => '$author <$email>') : ()),
+END
+if (!$opt_X) { # print C stuff, unless XS is disabled
+  $opt_F = '' unless defined $opt_F;
+  my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
+  my $Ihelp = ($I ? '-I. ' : '');
+  my $Icomment = ($I ? '' : <<EOC);
+	# Insert -I. if you add *.h files later:
+EOC
+
+  print PL <<END;
+    LIBS              => ['$extralibs'], # e.g., '-lm'
+    DEFINE            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
+$Icomment    INC               => '$I', # e.g., '${Ihelp}-I/usr/include/other'
+END
+
+  my $C = grep {$_ ne "$modfname.c"}
+    (glob '*.c'), (glob '*.cc'), (glob '*.C');
+  my $Cpre = ($C ? '' : '# ');
+  my $Ccomment = ($C ? '' : <<EOC);
+	# Un-comment this if you add C files to link with later:
+EOC
+
+  print PL <<END;
+$Ccomment    ${Cpre}OBJECT            => '\$(O_FILES)', # link all the C files too
+END
+} # ' # 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_names,
+                 );
+  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 doesnt hurt to have one
+warn "Writing $ext$modpname/README\n";
+open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
+my $thisyear = (gmtime)[5] + 1900;
+my $rmhead = "$modpname version $TEMPLATE_VERSION";
+my $rmheadeq = "=" x length($rmhead);
+
+my $rm_prereq;
+
+if ( $compat_version < 5.00702 and $new_test )
+{
+   $rm_prereq = 'Test::More';
+}
+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';
+
+_END_
+
+my $test_mod = 'Test::More';
+
+if ( $old_test or ($compat_version < 5.007 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@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",@files), "\n";
+close MANI;
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/instmodsh.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/instmodsh.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/instmodsh.bat	(revision 19631)
@@ -0,0 +1,211 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if $running_under_some_shell;
+#!/usr/bin/perl -w
+
+use strict;
+use IO::File;
+use ExtUtils::Packlist;
+use ExtUtils::Installed;
+
+use vars qw($Inst @Modules);
+
+
+=head1 NAME
+
+instmodsh - A shell to examine installed modules
+
+=head1 SYNOPSIS
+
+    instmodsh
+
+=head1 DESCRIPTION
+
+A little interface to ExtUtils::Installed to examine installed modules,
+validate your packlists and even create a tarball from an installed module.
+
+=head1 SEE ALSO
+
+ExtUtils::Installed
+
+=cut
+
+
+my $Module_Help = <<EOF;
+Available commands are:
+   f [all|prog|doc]   - List installed files of a given type
+   d [all|prog|doc]   - List the directories used by a module
+   v                  - Validate the .packlist - check for missing files
+   t <tarfile>        - Create a tar archive of the module
+   h                  - Display module help
+   q                  - Quit the module
+EOF
+
+my %Module_Commands = (
+                       f => \&list_installed,
+                       d => \&list_directories,
+                       v => \&validate_packlist,
+                       t => \&create_archive,
+                       h => \&module_help,
+                      );
+
+sub do_module($) {
+    my ($module) = @_;
+
+    print($Module_Help);
+    MODULE_CMD: while (1) {
+        print("$module cmd? ");
+
+        my $reply = <STDIN>; chomp($reply);
+        my($cmd) = $reply =~ /^(\w)\b/;
+
+        last if $cmd eq 'q';
+
+        if( $Module_Commands{$cmd} ) {
+            $Module_Commands{$cmd}->($reply, $module);
+        }
+        elsif( $cmd eq 'q' ) {
+            last MODULE_CMD;
+        }
+        else {
+            module_help();
+        }
+    }
+}
+
+
+sub list_installed {
+    my($reply, $module) = @_;
+
+    my $class = (split(' ', $reply))[1];
+    $class = 'all' unless $class;
+
+    my @files;
+    if (eval { @files = $Inst->files($module, $class); }) {
+        print("$class files in $module are:\n   ",
+              join("\n   ", @files), "\n");
+    }
+    else { 
+        print($@); 
+    }
+};
+
+
+sub list_directories {
+    my($reply, $module) = @_;
+
+    my $class = (split(' ', $reply))[1];
+    $class = 'all' unless $class;
+
+    my @dirs;
+    if (eval { @dirs = $Inst->directories($module, $class); }) {
+        print("$class directories in $module are:\n   ",
+              join("\n   ", @dirs), "\n");
+    }
+    else { 
+        print($@); 
+    }
+}
+
+
+sub create_archive {
+    my($reply, $module) = @_;
+
+    my $file = (split(' ', $reply))[1];
+
+    if( !(defined $file and length $file) ) {
+        print "No tar file specified\n";
+    }
+    elsif( eval { require Archive::Tar } ) {
+        Archive::Tar->create_archive($file, 0, $Inst->files($module));
+    }
+    else {
+        my($first, @rest) = $Inst->files($module);
+        system('tar', 'cvf', $file, $first);
+        for my $f (@rest) {
+            system('tar', 'rvf', $file, $f);
+        }
+        print "Can't use tar\n" if $?;
+    }
+}
+
+
+sub validate_packlist {
+    my($reply, $module) = @_;
+
+    if (my @missing = $Inst->validate($module)) {
+        print("Files missing from $module are:\n   ",
+              join("\n   ", @missing), "\n");
+    }
+    else {
+        print("$module has no missing files\n");
+    }
+}
+
+sub module_help {
+    print $Module_Help;
+}
+
+
+
+##############################################################################
+
+sub toplevel()
+{
+my $help = <<EOF;
+Available commands are:
+   l            - List all installed modules
+   m <module>   - Select a module
+   q            - Quit the program
+EOF
+print($help);
+while (1)
+   {
+   print("cmd? ");
+   my $reply = <STDIN>; chomp($reply);
+   CASE:
+      {
+      $reply eq 'l' and do
+         {
+         print("Installed modules are:\n   ", join("\n   ", @Modules), "\n");
+         last CASE;
+         };
+      $reply =~ /^m\s+/ and do
+         {
+         do_module((split(' ', $reply))[1]);
+         last CASE;
+         };
+      $reply eq 'q' and do
+         {
+         exit(0);
+         };
+      # Default
+         print($help);
+      }
+   }
+}
+
+
+###############################################################################
+
+$Inst = ExtUtils::Installed->new();
+@Modules = $Inst->modules();
+toplevel();
+
+###############################################################################
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/libnetcfg.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/libnetcfg.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/libnetcfg.bat	(revision 19631)
@@ -0,0 +1,737 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if $running_under_some_shell;
+
+=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<Net::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 $
+
+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(" ",@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,@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",@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 = ( %{ 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@remote.host
+     PASS pass
+2) -----------------------
+     USER fwuser
+     PASS fwpass
+     USER user@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@fwuser@remote.site
+     PASS pass@fwpass
+6) -----------------------
+     USER fwuser@remote.site
+     PASS fwpass
+     USER user
+     PASS pass
+7) -----------------------
+     USER user@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;
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlbug.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlbug.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlbug.bat	(revision 19631)
@@ -0,0 +1,1223 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if $running_under_some_shell;
+
+my $config_tag1 = 'v5.8.8 - Wed Aug  2 11:33:07 2006';
+
+my $patchlevel_date = 1138720330;
+my $patch_tags = '';
+my @patches = (
+    ''
+);
+
+use Config;
+use File::Spec;		# keep perlbug Perl 5.005 compatible
+use Getopt::Std;
+use strict;
+
+sub paraprint;
+
+BEGIN {
+    eval "use Mail::Send;";
+    $::HaveSend = ($@ eq "");
+    eval "use Mail::Util;";
+    $::HaveUtil = ($@ eq "");
+    # use secure tempfiles wherever possible
+    eval "require File::Temp;";
+    $::HaveTemp = ($@ eq "");
+};
+
+my $Version = "1.35";
+
+# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
+# Changed in 1.07 to see more sendmail execs, and added pipe output.
+# Changed in 1.08 to use correct address for sendmail.
+# Changed in 1.09 to close the REP file before calling it up in the editor.
+#                 Also removed some old comments duplicated elsewhere.
+# Changed in 1.10 to run under VMS without Mail::Send; also fixed
+#                 temp filename generation.
+# Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
+# Changed in 1.12 to check for editor errors, make save/send distinction
+#                 clearer and add $ENV{REPLYTO}.
+# Changed in 1.13 to hopefully make it more difficult to accidentally
+#                 send mail
+# Changed in 1.14 to make the prompts a little more clear on providing
+#                 helpful information. Also let file read fail gracefully.
+# Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
+#                 Also report selected environment variables.
+# Changed in 1.16 to include @INC, and allow user to re-edit if no changes.
+# Changed in 1.17 Win32 support added.  GSAR 97-04-12
+# Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18
+# Changed in 1.19 '-ok' default not '-v'
+#                 add local patch information
+#                 warn on '-ok' if this is an old system; add '-okay'
+# Changed in 1.20 Added patchlevel.h reading and version/config checks
+# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05
+# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10
+# Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt
+# Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
+# Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
+# Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
+# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
+# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
+# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000
+# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
+# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
+# Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000
+# Changed in 1.33 Don't require -t STDOUT for -ok.
+# Changed in 1.34 Added Message-Id RFOLEY 18-06-2002 
+# Changed in 1.35 Use File::Temp (patch from Solar Designer) NWCLARK 28-02-2004
+
+# TODO: - Allow the user to re-name the file on mail failure, and
+#       make sure failure (transmission-wise) of Mail::Send is
+#       accounted for.
+#       - Test -b option
+
+my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, $messageid, $domain,
+    $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity,
+    $fh, $me, $Is_MSWin32, $Is_Linux, $Is_VMS, $msg, $body, $andcc, %REP, $ok,
+    $Is_OpenBSD);
+
+my $perl_version = $^V ? sprintf("v%vd", $^V) : $];
+
+my $config_tag2 = "$perl_version - $Config{cf_time}";
+
+Init();
+
+if ($::opt_h) { Help(); exit; }
+if ($::opt_d) { Dump(*STDOUT); exit; }
+if (!-t STDIN && !($ok and not $::opt_n)) {
+    paraprint <<EOF;
+Please use perlbug interactively. If you want to
+include a file, you can use the -f switch.
+EOF
+    die "\n";
+}
+
+Query();
+Edit() unless $usefile || ($ok and not $::opt_n);
+NowWhat();
+Send();
+
+exit;
+
+sub ask_for_alternatives { # (category|severity)
+    my $name = shift;
+    my %alts = (
+	'category' => {
+	    'default' => 'core',
+	    'ok'      => 'install',
+	    'opts'    => [qw(core docs install library utilities)], # patch, notabug
+	},
+	'severity' => {
+	    'default' => 'low',
+	    'ok'      => 'none',
+	    'opts'    => [qw(critical high medium low wishlist none)], # zero
+	},
+    );
+    die "Invalid alternative($name) requested\n" unless grep(/^$name$/, keys %alts);
+    my $alt = "";
+    if ($ok) {
+	$alt = $alts{$name}{'ok'};
+    } else {
+ 	my @alts = @{$alts{$name}{'opts'}};
+	paraprint <<EOF;
+Please pick a \u$name from the following:
+
+    @alts
+
+EOF
+	my $err = 0;
+	do {
+	    if ($err++ > 5) {
+		die "Invalid $name: aborting.\n";
+	    }
+	    print "Please enter a \u$name [$alts{$name}{'default'}]: ";
+	    $alt = <>;
+	    chomp $alt;
+	    if ($alt =~ /^\s*$/) {
+		$alt = $alts{$name}{'default'};
+	    }
+	} while !((($alt) = grep(/^$alt/i, @alts)));
+    }
+    lc $alt;
+}
+
+sub Init {
+    # -------- Setup --------
+
+    $Is_MSWin32 = $^O eq 'MSWin32';
+    $Is_VMS = $^O eq 'VMS';
+    $Is_Linux = lc($^O) eq 'linux';
+    $Is_OpenBSD = lc($^O) eq 'openbsd';
+    $Is_MacOS = $^O eq 'MacOS';
+
+    @ARGV = split m/\s+/,
+        MacPerl::Ask('Provide command-line args here (-h for help):')
+        if $Is_MacOS && $MacPerl::Version =~ /App/;
+
+    if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; };
+
+    # This comment is needed to notify metaconfig that we are
+    # using the $perladmin, $cf_by, and $cf_time definitions.
+
+    # -------- Configuration ---------
+
+    # perlbug address
+    $perlbug = 'perlbug@perl.org';
+
+    # Test address
+    $testaddress = 'perlbug-test@perl.org';
+
+    # Target address
+    $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug);
+
+    # Users address, used in message and in Reply-To header
+    $from = $::opt_r || "";
+
+    # Include verbose configuration information
+    $verbose = $::opt_v || 0;
+
+    # Subject of bug-report message
+    $subject = $::opt_s || "";
+
+    # Send a file
+    $usefile = ($::opt_f || 0);
+
+    # File to send as report
+    $file = $::opt_f || "";
+
+    # File to output to
+    $outfile = $::opt_F || "";
+
+    # Body of report
+    $body = $::opt_b || "";
+	
+    # Editor
+    $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
+	|| ($Is_VMS && "edit/tpu")
+	|| ($Is_MSWin32 && "notepad")
+	|| ($Is_MacOS && '')
+	|| "vi";
+
+    # Not OK - provide build failure template by finessing OK report
+    if ($::opt_n) {
+	if (substr($::opt_n, 0, 2) eq 'ok' )	{
+	    $::opt_o = substr($::opt_n, 1);
+	} else {
+	    Help();
+	    exit();
+	}
+    }
+
+    # OK - send "OK" report for build on this system
+    $ok = 0;
+    if ($::opt_o) {
+	if ($::opt_o eq 'k' or $::opt_o eq 'kay') {
+	    my $age = time - $patchlevel_date;
+	    if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) {
+		my $date = localtime $patchlevel_date;
+		print <<"EOF";
+"perlbug -ok" and "perlbug -nok" do not report on Perl versions which
+are more than 60 days old.  This Perl version was constructed on
+$date.  If you really want to report this, use
+"perlbug -okay" or "perlbug -nokay".
+EOF
+		exit();
+	    }
+	    # force these options
+	    unless ($::opt_n) {
+		$::opt_S = 1; # don't prompt for send
+		$::opt_b = 1; # we have a body
+		$body = "Perl reported to build OK on this system.\n";
+	    }
+	    $::opt_C = 1; # don't send a copy to the local admin
+	    $::opt_s = 1; # we have a subject line
+	    $subject = ($::opt_n ? 'Not ' : '')
+		    . "OK: perl $perl_version ${patch_tags}on"
+		    ." $::Config{'archname'} $::Config{'osvers'} $subject";
+	    $ok = 1;
+	} else {
+	    Help();
+	    exit();
+	}
+    }
+
+    # Possible administrator addresses, in order of confidence
+    # (Note that cf_email is not mentioned to metaconfig, since
+    # we don't really want it. We'll just take it if we have to.)
+    #
+    # This has to be after the $ok stuff above because of the way
+    # that $::opt_C is forced.
+    $cc = $::opt_C ? "" : (
+	$::opt_c || $::Config{'perladmin'}
+	|| $::Config{'cf_email'} || $::Config{'cf_by'}
+    );
+
+    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'}
+	    : $Is_MacOS ? $ENV{'USER'}
+	    : eval { getpwuid($<) };	# May be missing
+
+    $from = $::Config{'cf_email'}
+       if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
+               ($me eq $::Config{'cf_by'});
+} # sub Init
+
+sub Query {
+    # Explain what perlbug is
+    unless ($ok) {
+	paraprint <<EOF;
+This program provides an easy way to create a message reporting a bug
+in perl, and e-mail it to $address.  It is *NOT* intended for
+sending test messages or simply verifying that perl works, *NOR* is it
+intended for reporting bugs in third-party perl modules.  It is *ONLY*
+a means of reporting verifiable problems with the core perl distribution,
+and any solutions to such problems, to the people who maintain perl.
+
+If you're just looking for help with perl, try posting to the Usenet
+newsgroup comp.lang.perl.misc.  If you're looking for help with using
+perl with CGI, try posting to comp.infosystems.www.programming.cgi.
+EOF
+    }
+
+    # Prompt for subject of message, if needed
+    
+    if (TrivialSubject($subject)) {
+	$subject = '';
+    }
+
+    unless ($subject) {
+	paraprint <<EOF;
+First of all, please provide a subject for the
+message. It should be a concise description of
+the bug or problem. "perl bug" or "perl problem"
+is not a concise description.
+EOF
+
+	my $err = 0;
+	do {
+	    print "Subject: ";
+	    $subject = <>;
+	    chomp $subject;
+	    if ($err++ == 5) {
+		die "Aborting.\n";
+	    }
+	} while (TrivialSubject($subject));
+    }
+
+    # Prompt for return address, if needed
+    unless ($from) {
+	# Try and guess return address
+	my $guess;
+
+	$guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
+        if ($Is_MacOS) {
+            require Mac::InternetConfig;
+            $guess = $Mac::InternetConfig::InternetConfig{
+                Mac::InternetConfig::kICEmail()
+            };
+        }
+
+	unless ($guess) {
+		# 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;
+Your e-mail address will be useful if you need to be contacted. If the
+default shown is not your full internet e-mail address, please correct it.
+EOF
+	    }
+	} else {
+	    paraprint <<EOF;
+So that you may be contacted if necessary, please enter
+your full internet e-mail address here.
+EOF
+	}
+
+	if ($ok && $guess) {
+	    # use it
+	    $from = $guess;
+	} else {
+	    # verify it
+	    print "Your address [$guess]: ";
+	    $from = <>;
+	    chomp $from;
+	    $from = $guess if $from eq '';
+	}
+    }
+
+    if ($from eq $cc or $me eq $cc) {
+	# Try not to copy ourselves
+	$cc = "yourself";
+    }
+
+    # Prompt for administrator address, unless an override was given
+    if( !$::opt_C and !$::opt_c ) {
+	paraprint <<EOF;
+A copy of this report can be sent to your local
+perl administrator. If the address is wrong, please
+correct it, or enter 'none' or 'yourself' to not send
+a copy.
+EOF
+	print "Local perl administrator [$cc]: ";
+	my $entry = scalar <>;
+	chomp $entry;
+
+	if ($entry ne "") {
+	    $cc = $entry;
+	    $cc = '' if $me eq $cc;
+	}
+    }
+
+    $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
+    $andcc = " and $cc" if $cc;
+
+    # Prompt for editor, if no override is given
+editor:
+    unless ($::opt_e || $::opt_f || $::opt_b) {
+	paraprint <<EOF;
+Now you need to supply the bug report. Try to make
+the report concise but descriptive. Include any
+relevant detail. If you are reporting something
+that does not work as you think it should, please
+try to include example of both the actual
+result, and what you expected.
+
+Some information about your local
+perl configuration will automatically be included
+at the end of the report. If you are using any
+unusual version of perl, please try and confirm
+exactly which versions are relevant.
+
+You will probably want to use an editor to enter
+the report. If "$ed" is the editor you want
+to use, then just press Enter, otherwise type in
+the name of the editor you would like to use.
+
+If you would like to use a prepared file, type
+"file", and you will be asked for the filename.
+EOF
+	print "Editor [$ed]: ";
+	my $entry =scalar <>;
+	chomp $entry;
+
+	$usefile = 0;
+	if ($entry eq "file") {
+	    $usefile = 1;
+	} elsif ($entry ne "") {
+	    $ed = $entry;
+	}
+    }
+
+    # Prompt for category of bug
+    $category ||= ask_for_alternatives('category');
+
+    # Prompt for severity of bug
+    $severity ||= ask_for_alternatives('severity');
+
+    # Generate scratch file to edit report in
+    $filename = filename();
+
+    # Prompt for file to read report from, if needed
+    if ($usefile and !$file) {
+filename:
+	paraprint <<EOF;
+What is the name of the file that contains your report?
+EOF
+	print "Filename: ";
+	my $entry = scalar <>;
+	chomp $entry;
+
+	if ($entry eq "") {
+	    paraprint <<EOF;
+No filename? I'll let you go back and choose an editor again.
+EOF
+	    goto editor;
+	}
+
+	unless (-f $entry and -r $entry) {
+	    paraprint <<EOF;
+I'm sorry, but I can't read from `$entry'. Maybe you mistyped the name of
+the file? If you don't want to send a file, just enter a blank line and you
+can get back to the editor selection.
+EOF
+	    goto filename;
+	}
+	$file = $entry;
+    }
+
+    # Generate report
+    open(REP,">$filename") or die "Unable to create report file `$filename': $!\n";
+    my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success";
+
+    print REP <<EOF;
+This is a $reptype report for perl from $from,
+generated with the help of perlbug $Version running under perl $perl_version.
+
+EOF
+
+    if ($body) {
+	print REP $body;
+    } elsif ($usefile) {
+	open(F, "<$file")
+		or die "Unable to read report file from `$file': $!\n";
+	while (<F>) {
+	    print REP $_
+	}
+	close(F) or die "Error closing `$file': $!";
+    } else {
+	print REP <<EOF;
+
+-----------------------------------------------------------------
+[Please enter your report here]
+
+
+
+[Please do not change anything below this line]
+-----------------------------------------------------------------
+EOF
+    }
+    Dump(*REP);
+    close(REP) or die "Error closing report file: $!";
+
+    # read in the report template once so that
+    # we can track whether the user does any editing.
+    # yes, *all* whitespace is ignored.
+    open(REP, "<$filename") or die "Unable to open report file `$filename': $!\n";
+    while (<REP>) {
+	s/\s+//g;
+	$REP{$_}++;
+    }
+    close(REP) or die "Error closing report file `$filename': $!";
+} # sub Query
+
+sub Dump {
+    local(*OUT) = @_;
+
+    print OUT <<EFF;
+---
+Flags:
+    category=$category
+    severity=$severity
+EFF
+    if ($::opt_A) {
+	print OUT <<EFF;
+    ack=no
+EFF
+    }
+    print OUT <<EFF;
+---
+EFF
+    print OUT "This perlbug was built using Perl $config_tag1\n",
+	    "It is being executed now by  Perl $config_tag2.\n\n"
+	if $config_tag2 ne $config_tag1;
+
+    print OUT <<EOF;
+Site configuration information for perl $perl_version:
+
+EOF
+    if ($::Config{cf_by} and $::Config{cf_time}) {
+	print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
+    }
+    print OUT Config::myconfig;
+
+    if (@patches) {
+	print OUT join "\n    ", "Locally applied patches:", @patches;
+	print OUT "\n";
+    };
+
+    print OUT <<EOF;
+
+---
+\@INC for perl $perl_version:
+EOF
+    for my $i (@INC) {
+	print OUT "    $i\n";
+    }
+
+    print OUT <<EOF;
+
+---
+Environment for perl $perl_version:
+EOF
+    my @env =
+        qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
+    push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
+    push @env, grep /^(?:PERL|LC_|LANG|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 =~ s/'/\\'/g;
+	    print OUT "$_='$value'\n";
+	}
+    }
+} # sub Dump
+
+sub Edit {
+    # Edit the report
+    if ($usefile || $body) {
+	paraprint <<EOF;
+Please make sure that the name of the editor you want to use is correct.
+EOF
+	print "Editor [$ed]: ";
+	my $entry =scalar <>;
+	chomp $entry;
+	$ed = $entry unless $entry eq '';
+    }
+
+tryagain:
+    my $sts;
+    $sts = system("$ed $filename") unless $Is_MacOS;
+    if ($Is_MacOS) {
+        require ExtUtils::MakeMaker;
+        ExtUtils::MM_MacOS::launch_file($filename);
+        paraprint <<EOF;
+Press Enter when done.
+EOF
+        scalar <>;
+    }
+    if ($sts) {
+	paraprint <<EOF;
+The editor you chose (`$ed') could apparently not be run!
+Did you mistype the name of your editor? If so, please
+correct it here, otherwise just press Enter.
+EOF
+	print "Editor [$ed]: ";
+	my $entry =scalar <>;
+	chomp $entry;
+
+	if ($entry ne "") {
+	    $ed = $entry;
+	    goto tryagain;
+	} else {
+	    paraprint <<EOF;
+You may want to save your report to a file, so you can edit and mail it
+yourself.
+EOF
+	}
+    }
+
+    return if ($ok and not $::opt_n) || $body;
+    # Check that we have a report that has some, eh, report in it.
+    my $unseen = 0;
+
+    open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
+    # a strange way to check whether any significant editing
+    # have been done: check whether any new non-empty lines
+    # have been added. Yes, the below code ignores *any* space
+    # in *any* line.
+    while (<REP>) {
+	s/\s+//g;
+	$unseen++ if $_ ne '' and not exists $REP{$_};
+    }
+
+    while ($unseen == 0) {
+	paraprint <<EOF;
+I am sorry but it looks like you did not report anything.
+EOF
+	print "Action (Retry Edit/Cancel) ";
+	my ($action) = scalar(<>);
+	if ($action =~ /^[re]/i) { # <R>etry <E>dit
+	    goto tryagain;
+	} elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit
+	    Cancel();
+	}
+    }
+} # sub Edit
+
+sub Cancel {
+    1 while unlink($filename);  # remove all versions under VMS
+    print "\nCancelling.\n";
+    exit(0);
+}
+
+sub NowWhat {
+    # Report is done, prompt for further action
+    if( !$::opt_S ) {
+	while(1) {
+	    paraprint <<EOF;
+Now that you have completed your report, would you like to send
+the message to $address$andcc, display the message on
+the screen, re-edit it, display/change the subject,
+or cancel without sending anything?
+You may also save the message as a file to mail at another time.
+EOF
+      retry:
+	    print "Action (Send/Display/Edit/Subject/Save to File): ";
+	    my $action = scalar <>;
+	    chomp $action;
+
+	    if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
+		my $file_save = $outfile || "perlbug.rep";
+		print "\n\nName of file to save message in [$file_save]: ";
+		my $file = scalar <>;
+		chomp $file;
+		$file = $file_save if $file eq "";
+
+		unless (open(FILE, ">$file")) {
+		    print "\nError opening $file: $!\n\n";
+		    goto retry;
+		}
+		open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
+		print FILE "To: $address\nSubject: $subject\n";
+		print FILE "Cc: $cc\n" if $cc;
+		print FILE "Reply-To: $from\n" if $from;
+		print FILE "Message-Id: $messageid\n" if $messageid;
+		print FILE "\n";
+		while (<REP>) { print FILE }
+		close(REP) or die "Error closing report file `$filename': $!";
+		close(FILE) or die "Error closing $file: $!";
+
+		print "\nMessage saved in `$file'.\n";
+		exit;
+	    } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
+		# Display the message
+		open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
+		while (<REP>) { print $_ }
+		close(REP) or die "Error closing report file `$filename': $!";
+	    } elsif ($action =~ /^su/i) { # <Su>bject
+		print "Subject: $subject\n";
+		print "If the above subject is fine, just press Enter.\n";
+		print "If not, type in the new subject.\n";
+		print "Subject: ";
+		my $reply = scalar <STDIN>;
+		chomp $reply;
+		if ($reply ne '') {
+		    unless (TrivialSubject($reply)) {
+			$subject = $reply;
+			print "Subject: $subject\n";
+		    }
+		}
+	    } elsif ($action =~ /^se/i) { # <S>end
+		# Send the message
+		print "Are you certain you want to send this message?\n"
+		    . 'Please type "yes" if you are: ';
+		my $reply = scalar <STDIN>;
+		chomp $reply;
+		if ($reply eq "yes") {
+		    last;
+		} else {
+		    paraprint <<EOF;
+That wasn't a clear "yes", so I won't send your message. If you are sure
+your message should be sent, type in "yes" (without the quotes) at the
+confirmation prompt.
+EOF
+		}
+	    } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit
+		# edit the message
+		Edit();
+	    } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
+		Cancel();
+	    } elsif ($action =~ /^s/i) {
+		paraprint <<EOF;
+I'm sorry, but I didn't understand that. Please type "send" or "save".
+EOF
+	    }
+	}
+    }
+} # sub NowWhat
+
+sub TrivialSubject {
+    my $subject = shift;
+    if ($subject =~
+	/^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
+	length($subject) < 4 ||
+	$subject !~ /\s/) {
+	print "\nThat doesn't look like a good subject.  Please be more verbose.\n\n";
+        return 1;
+    } else {
+	return 0;
+    }
+}
+
+sub Send {
+    # Message has been accepted for transmission -- Send the message
+    if ($outfile) {
+	open SENDMAIL, ">$outfile" or die "Couldn't open '$outfile': $!\n";
+	goto sendout;
+    }
+
+    # 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
+    if ($::HaveSend && !$Is_Linux && !$Is_OpenBSD) {
+	$msg = new Mail::Send Subject => $subject, To => $address;
+	$msg->cc($cc) if $cc;
+	$msg->add("Reply-To",$from) if $from;
+
+	$fh = $msg->open;
+	open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
+	while (<REP>) { print $fh $_ }
+	close(REP) or die "Error closing $filename: $!";
+	$fh->close;
+
+	print "\nMessage sent.\n";
+    } elsif ($Is_VMS) {
+	if ( ($address =~ /@/ and $address !~ /^\w+%"/) or
+	     ($cc      =~ /@/ and $cc      !~ /^\w+%"/) ) {
+	    my $prefix;
+	    foreach (qw[ IN MX SMTP UCX PONY WINS ], '') {
+		$prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"};
+	    }
+	    $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
+	    $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
+	}
+	$subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g;
+	my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
+	if ($sts) {
+	    die <<EOF;
+Can't spawn off mail
+	(leaving bug report in $filename): $sts
+EOF
+	}
+    } else {
+	my $sendmail = "";
+	for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) {
+	    $sendmail = $_, last if -e $_;
+	}
+	if ($^O eq 'os2' and $sendmail eq "") {
+	    my $path = $ENV{PATH};
+	    $path =~ s:\\:/: ;
+	    my @path = split /$Config{'path_sep'}/, $path;
+	    for (@path) {
+		$sendmail = "$_/sendmail", last if -e "$_/sendmail";
+		$sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe";
+	    }
+	}
+
+	paraprint(<<"EOF"), die "\n" if $sendmail eq "";
+I am terribly sorry, but I cannot find sendmail, or a close equivalent, and
+the perl package Mail::Send has not been installed, so I can't send your bug
+report. We apologize for the inconvenience.
+
+So you may attempt to find some way of sending your message, it has
+been left in the file `$filename'.
+EOF
+	open(SENDMAIL, "|$sendmail -t -oi") || die "'|$sendmail -t -oi' failed: $!";
+sendout:
+	print SENDMAIL "To: $address\n";
+	print SENDMAIL "Subject: $subject\n";
+	print SENDMAIL "Cc: $cc\n" if $cc;
+	print SENDMAIL "Reply-To: $from\n" if $from;
+	print SENDMAIL "Message-Id: $messageid\n" if $messageid;
+	print SENDMAIL "\n\n";
+	open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
+	while (<REP>) { print SENDMAIL $_ }
+	close(REP) or die "Error closing $filename: $!";
+
+	if (close(SENDMAIL)) {
+	    printf "\nMessage %s.\n", $outfile ? "saved" : "sent";
+	} else {
+	    warn "\nSendmail returned status '", $? >> 8, "'\n";
+	}
+    }
+    1 while unlink($filename);  # remove all versions under VMS
+} # sub Send
+
+sub Help {
+    print <<EOF;
+
+A program to help generate bug reports about perl5, and mail them.
+It is designed to be used interactively. Normally no arguments will
+be needed.
+
+Usage:
+$0  [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
+    [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
+$0  [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
+
+Simplest usage:  run "$0", and follow the prompts.
+
+Options:
+
+  -v    Include Verbose configuration data in the report
+  -f    File containing the body of the report. Use this to
+        quickly send a prepared message.
+  -F    File to output the resulting mail message to, instead of mailing.
+  -S    Send without asking for confirmation.
+  -a    Address to send the report to. Defaults to `$address'.
+  -c    Address to send copy of report to. Defaults to `$cc'.
+  -C    Don't send copy to administrator.
+  -s    Subject to include with the message. You will be prompted
+        if you don't supply one on the command line.
+  -b    Body of the report. If not included on the command line, or
+        in a file with -f, you will get a chance to edit the message.
+  -r    Your return address. The program will ask you to confirm
+        this if you don't give it here.
+  -e    Editor to use.
+  -t    Test mode. The target address defaults to `$testaddress'.
+  -d    Data mode.  This prints out your configuration data, without mailing
+        anything. You can use this with -v to get more complete data.
+  -A    Don't send a bug received acknowledgement to the return address.
+  -ok   Report successful build on this system to perl porters
+        (use alone or with -v). Only use -ok if *everything* was ok:
+        if there were *any* problems at all, use -nok.
+  -okay As -ok but allow report from old builds.
+  -nok  Report unsuccessful build on this system to perl porters
+        (use alone or with -v). You must describe what went wrong
+        in the body of the report which you will be asked to edit.
+  -nokay As -nok but allow report from old builds.
+  -h    Print this help message.
+
+EOF
+}
+
+sub filename {
+    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,}/, "@_";
+    print "\n\n";
+    for (@paragraphs) {   # implicit local $_
+	s/(\S)\s*\n/$1 /g;
+	write;
+	print "\n";
+    }
+}
+
+format STDOUT =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
+$_
+.
+
+__END__
+
+=head1 NAME
+
+perlbug - how to submit bug reports on Perl
+
+=head1 SYNOPSIS
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
+S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
+S<[ B<-r> I<returnaddress> ]>
+S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
+S<[ B<-S> ]> S<[ B<-t> ]>  S<[ B<-d> ]>  S<[ B<-A> ]>  S<[ B<-h> ]>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
+ S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+
+=head1 DESCRIPTION
+
+A program to help generate bug reports about perl or the modules that
+come with it, and mail them.
+
+If you have found a bug with a non-standard port (one that was not part
+of the I<standard distribution>), a binary distribution, or a
+non-standard module (such as Tk, CGI, etc), then please see the
+documentation that came with that distribution to determine the correct
+place to report bugs.
+
+C<perlbug> is designed to be used interactively. Normally no arguments
+will be needed.  Simply run it, and follow the prompts.
+
+If you are unable to run B<perlbug> (most likely because you don't have
+a working setup to send mail that perlbug recognizes), you may have to
+compose your own report, and email it to B<perlbug@perl.org>.  You might
+find the B<-d> option useful to get summary information in that case.
+
+In any case, when reporting a bug, please make sure you have run through
+this checklist:
+
+=over 4
+
+=item What version of Perl you are running?
+
+Type C<perl -v> at the command line to find out.
+
+=item Are you running the latest released version of perl?
+
+Look at http://www.perl.com/ to find out.  If it is not the latest
+released version, get that one and see whether your bug has been
+fixed.  Note that bug reports about old versions of Perl, especially
+those prior to the 5.0 release, are likely to fall upon deaf ears.
+You are on your own if you continue to use perl1 .. perl4.
+
+=item Are you sure what you have is a bug?
+
+A significant number of the bug reports we get turn out to be documented
+features in Perl.  Make sure the behavior you are witnessing doesn't fall
+under that category, by glancing through the documentation that comes
+with Perl (we'll admit this is no mean task, given the sheer volume of
+it all, but at least have a look at the sections that I<seem> relevant).
+
+Be aware of the familiar traps that perl programmers of various hues
+fall into.  See L<perltrap>.
+
+Check in L<perldiag> to see what any Perl error message(s) mean.
+If message isn't in perldiag, it probably isn't generated by Perl.
+Consult your operating system documentation instead.
+
+If you are on a non-UNIX platform check also L<perlport>, as some
+features may be unimplemented or work differently.
+
+Try to study the problem under the Perl debugger, if necessary.
+See L<perldebug>.
+
+=item Do you have a proper test case?
+
+The easier it is to reproduce your bug, the more likely it will be
+fixed, because if no one can duplicate the problem, no one can fix it.
+A good test case has most of these attributes: fewest possible number
+of lines; few dependencies on external commands, modules, or
+libraries; runs on most platforms unimpeded; and is self-documenting.
+
+A good test case is almost always a good candidate to be on the perl
+test suite.  If you have the time, consider making your test case so
+that it will readily fit into the standard test suite.
+
+Remember also to include the B<exact> error messages, if any.
+"Perl complained something" is not an exact error message.
+
+If you get a core dump (or equivalent), you may use a debugger
+(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug
+report.  NOTE: unless your Perl has been compiled with debug info
+(often B<-g>), the stack trace is likely to be somewhat hard to use
+because it will most probably contain only the function names and not
+their arguments.  If possible, recompile your Perl with debug info and
+reproduce the dump and the stack trace.
+
+=item Can you describe the bug in plain English?
+
+The easier it is to understand a reproducible bug, the more likely it
+will be fixed.  Anything you can provide by way of insight into the
+problem helps a great deal.  In other words, try to analyze the
+problem (to the extent you can) and report your discoveries.
+
+=item Can you fix the bug yourself?
+
+A bug report which I<includes a patch to fix it> will almost
+definitely be fixed.  Use the C<diff> program to generate your patches
+(C<diff> is being maintained by the GNU folks as part of the B<diffutils>
+package, so you should be able to get it from any of the GNU software
+repositories).  If you do submit a patch, the cool-dude counter at
+perlbug@perl.org will register you as a savior of the world.  Your
+patch may be returned with requests for changes, or requests for more
+detailed explanations about your fix.
+
+Here are some clues for creating quality patches: Use the B<-c> or
+B<-u> switches to the diff program (to create a so-called context or
+unified diff).  Make sure the patch is not reversed (the first
+argument to diff is typically the original file, the second argument
+your changed file).  Make sure you test your patch by applying it with
+the C<patch> program before you send it on its way.  Try to follow the
+same style as the code you are trying to patch.  Make sure your patch
+really does work (C<make test>, if the thing you're patching supports
+it).
+
+=item Can you use C<perlbug> to submit the report?
+
+B<perlbug> will, amongst other things, ensure your report includes
+crucial information about your version of perl.  If C<perlbug> is unable
+to mail your report after you have typed it in, you may have to compose
+the message yourself, add the output produced by C<perlbug -d> and email
+it to B<perlbug@perl.org>.  If, for some reason, you cannot run
+C<perlbug> at all on your system, be sure to include the entire output
+produced by running C<perl -V> (note the uppercase V).
+
+Whether you use C<perlbug> or send the email manually, please make
+your Subject line informative.  "a bug" not informative.  Neither is
+"perl crashes" nor "HELP!!!".  These don't help.
+A compact description of what's wrong is fine.
+
+=back
+
+Having done your bit, please be prepared to wait, to be told the bug
+is in your code, or even to get no reply at all.  The Perl maintainers
+are busy folks, so if your problem is a small one or if it is difficult
+to understand or already known, they may not respond with a personal reply.
+If it is important to you that your bug be fixed, do monitor the
+C<Changes> file in any development releases since the time you submitted
+the bug, and encourage the maintainers with kind words (but never any
+flames!).  Feel free to resend your bug report if the next released
+version of perl comes out and your bug is still present.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-a>
+
+Address to send the report to.  Defaults to B<perlbug@perl.org>.
+
+=item B<-A>
+
+Don't send a bug received acknowledgement to the reply address.
+Generally it is only a sensible to use this option if you are a
+perl maintainer actively watching perl porters for your message to
+arrive.
+
+=item B<-b>
+
+Body of the report.  If not included on the command line, or
+in a file with B<-f>, you will get a chance to edit the message.
+
+=item B<-C>
+
+Don't send copy to administrator.
+
+=item B<-c>
+
+Address to send copy of report to.  Defaults to the address of the
+local perl administrator (recorded when perl was built).
+
+=item B<-d>
+
+Data mode (the default if you redirect or pipe output).  This prints out
+your configuration data, without mailing anything.  You can use this
+with B<-v> to get more complete data.
+
+=item B<-e>
+
+Editor to use.
+
+=item B<-f>
+
+File containing the body of the report.  Use this to quickly send a
+prepared message.
+
+=item B<-F>
+
+File to output the results to instead of sending as an email. Useful
+particularly when running perlbug on a machine with no direct internet
+connection.
+
+=item B<-h>
+
+Prints a brief summary of the options.
+
+=item B<-ok>
+
+Report successful build on this system to perl porters. Forces B<-S>
+and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
+prompts for a return address if it cannot guess it (for use with
+B<make>). Honors return address specified with B<-r>.  You can use this
+with B<-v> to get more complete data.   Only makes a report if this
+system is less than 60 days old.
+
+=item B<-okay>
+
+As B<-ok> except it will report on older systems.
+
+=item B<-nok>
+
+Report unsuccessful build on this system.  Forces B<-C>.  Forces and
+supplies a value for B<-s>, then requires you to edit the report
+and say what went wrong.  Alternatively, a prepared report may be
+supplied using B<-f>.  Only prompts for a return address if it
+cannot guess it (for use with B<make>). Honors return address
+specified with B<-r>.  You can use this with B<-v> to get more
+complete data.  Only makes a report if this system is less than 60
+days old.
+
+=item B<-nokay>
+
+As B<-nok> except it will report on older systems.
+
+=item B<-r>
+
+Your return address.  The program will ask you to confirm its default
+if you don't use this option.
+
+=item B<-S>
+
+Send without asking for confirmation.
+
+=item B<-s>
+
+Subject to include with the message.  You will be prompted if you don't
+supply one on the command line.
+
+=item B<-t>
+
+Test mode.  The target address defaults to B<perlbug-test@perl.org>.
+
+=item B<-v>
+
+Include verbose configuration data in the report.
+
+=back
+
+=head1 AUTHORS
+
+Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored
+by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>), Tom Christiansen
+(E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>),
+Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy
+(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>),
+Hugo van der Sanden (E<lt>hv@crypt.org<gt>),
+Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
+(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
+and Richard Foley (E<lt>richard@rfi.netE<gt>).
+
+=head1 SEE ALSO
+
+perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
+diff(1), patch(1), dbx(1), gdb(1)
+
+=head1 BUGS
+
+None known (guess what must have been used to report them?)
+
+=cut
+
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlcc.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlcc.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlcc.bat	(revision 19631)
@@ -0,0 +1,666 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+    if $running_under_some_shell;
+--$running_under_some_shell;
+
+# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000 
+# Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000
+# Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000
+# Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001
+# Version 2.04, Enache Adrian,Fri, 18 Jul 2003 23:15:37 +0300
+
+use strict;
+use warnings;
+use 5.006_000;
+
+use FileHandle;
+use Config;
+use Fcntl qw(:DEFAULT :flock);
+use File::Temp qw(tempfile);
+use Cwd;
+our $VERSION = 2.04;
+$| = 1;
+
+$SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves.
+
+use subs qw{
+    cc_harness check_read check_write checkopts_byte choose_backend
+    compile_byte compile_cstyle compile_module generate_code
+    grab_stash parse_argv sanity_check vprint yclept spawnit
+};
+sub opt(*); # imal quoting
+sub is_win32();
+sub is_msvc();
+
+our ($Options, $BinPerl, $Backend);
+our ($Input => $Output);
+our ($logfh);
+our ($cfile);
+our (@begin_output); # output from BEGIN {}, for testsuite
+
+# eval { main(); 1 } or die;
+
+main();
+
+sub main {
+    parse_argv();
+    check_write($Output);
+    choose_backend();
+    generate_code();
+    run_code();
+    _die("XXX: Not reached?");
+}
+
+#######################################################################
+
+sub choose_backend {
+    # Choose the backend.
+    $Backend = 'C';
+    if (opt(B)) {
+        checkopts_byte();
+        $Backend = 'Bytecode';
+    }
+    if (opt(S) && opt(c)) {
+        # die "$0: Do you want me to compile this or not?\n";
+        delete $Options->{S};
+    }
+    $Backend = 'CC' if opt(O);
+}
+
+
+sub generate_code { 
+
+    vprint 0, "Compiling $Input";
+
+    $BinPerl  = yclept();  # Calling convention for perl.
+
+    if (opt(shared)) {
+        compile_module();
+    } else {
+        if ($Backend eq 'Bytecode') {
+            compile_byte();
+        } else {
+            compile_cstyle();
+        }
+    }
+    exit(0) if (!opt('r'));
+}
+
+sub run_code {
+    vprint 0, "Running code";
+    run("$Output @ARGV");
+    exit(0);
+}
+
+# usage: vprint [level] msg args
+sub vprint {
+    my $level;
+    if (@_ == 1) {
+        $level = 1;
+    } elsif ($_[0] =~ /^\d$/) {
+        $level = shift;
+    } else {
+        # well, they forgot to use a number; means >0
+        $level = 0;
+    } 
+    my $msg = "@_";
+    $msg .= "\n" unless substr($msg, -1) eq "\n";
+    if (opt(v) > $level)
+    {
+         print        "$0: $msg" if !opt('log');
+	 print $logfh "$0: $msg" if  opt('log');
+    }
+}
+
+sub parse_argv {
+
+    use Getopt::Long; 
+
+    # disallows using long arguments
+    # Getopt::Long::Configure("bundling");
+
+    Getopt::Long::Configure("no_ignore_case");
+
+    # no difference in exists and defined for %ENV; also, a "0"
+    # argument or a "" would not help cc, so skip
+    unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
+
+    $Options = {};
+    Getopt::Long::GetOptions( $Options,
+        'L:s',          # lib directory
+        'I:s',          # include directories (FOR C, NOT FOR PERL)
+        'o:s',          # Output executable
+        'v:i',          # Verbosity level
+        'e:s',          # One-liner
+	'r',            # run resulting executable
+        'B',            # Byte compiler backend
+        'O',            # Optimised C backend
+        'c',            # Compile only
+        'h',            # Help me
+        'S',            # Dump C files
+	'r',            # run the resulting executable
+        'T',            # run the backend using perl -T
+        't',            # run the backend using perl -t
+        'static',       # Dirty hack to enable -shared/-static
+        'shared',       # Create a shared library (--shared for compat.)
+	'log:s',        # where to log compilation process information
+        'Wb:s',         # pass (comma-sepearated) options to backend
+        'testsuite',    # try to be nice to testsuite
+    );
+
+    $Options->{v} += 0;
+
+    if( opt(t) && opt(T) ) {
+        warn "Can't specify both -T and -t, -t ignored";
+        $Options->{t} = 0;
+    }
+
+    helpme() if opt(h); # And exit
+
+    $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' );
+    $Output = is_win32() ? $Output : relativize($Output);
+    $logfh  = new FileHandle(">> " . opt('log')) if (opt('log'));
+
+    if (opt(e)) {
+        warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;
+        # We don't use a temporary file here; why bother?
+        # XXX: this is not bullet proof -- spaces or quotes in name!
+        $Input = is_win32() ? # Quotes eaten by shell
+            '-e "'.opt(e).'"' :
+            "-e '".opt(e)."'";
+    } else {
+        $Input = shift @ARGV;  # XXX: more files?
+        _usage_and_die("$0: No input file specified\n") unless $Input;
+        # DWIM modules. This is bad but necessary.
+        $Options->{shared}++ if $Input =~ /\.pm\z/;
+        warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV;
+        check_read($Input);
+        check_perl($Input);
+        sanity_check();
+    }
+
+}
+
+sub opt(*) {
+    my $opt = shift;
+    return exists($Options->{$opt}) && ($Options->{$opt} || 0);
+} 
+
+sub compile_module { 
+    die "$0: Compiling to shared libraries is currently disabled\n";
+}
+
+sub compile_byte {
+    my $command = "$BinPerl -MO=Bytecode,-H,-o$Output $Input";
+    $Input =~ s/^-e.*$/-e/;
+
+    my ($output_r, $error_r) = spawnit($command);
+
+    if (@$error_r && $? != 0) {
+	_die("$0: $Input did not compile:\n@$error_r\n");
+    } else {
+	my @error = grep { !/^$Input syntax OK$/o } @$error_r;
+	warn "$0: Unexpected compiler output:\n@error" if @error;
+    }
+
+    chmod 0777 & ~umask, $Output    or _die("can't chmod $Output: $!");
+    exit 0;
+}
+
+sub compile_cstyle {
+    my $stash = grab_stash();
+    my $taint = opt(T) ? '-T' :
+                opt(t) ? '-t' : '';
+
+    # What are we going to call our output C file?
+    my $lose = 0;
+    my ($cfh);
+    my $testsuite = '';
+    my $addoptions = opt(Wb);
+
+    if( $addoptions ) {
+        $addoptions .= ',' if $addoptions !~ m/,$/;
+    }
+
+    if (opt(testsuite)) {
+        my $bo = join '', @begin_output;
+        $bo =~ s/\\/\\\\\\\\/gs;
+        $bo =~ s/\n/\\n/gs;
+        $bo =~ s/,/\\054/gs;
+        # don't look at that: it hurts
+        $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}.
+            qq[-e"print q{$bo}",] .
+            q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .
+            q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};
+    }
+    if (opt(S) || opt(c)) {
+        # We need to keep it.
+        if (opt(e)) {
+            $cfile = "a.out.c";
+        } else {
+            $cfile = $Input;
+            # File off extension if present
+            # hold on: plx is executable; also, careful of ordering!
+            $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
+            $cfile .= ".c";
+            $cfile = $Output if opt(c) && $Output =~ /\.c\z/i;
+        }
+        check_write($cfile);
+    } else {
+        # Don't need to keep it, be safe with a tempfile.
+        $lose = 1;
+        ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c"); 
+        close $cfh; # See comment just below
+    }
+    vprint 1, "Writing C on $cfile";
+
+    my $max_line_len = '';
+    if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {
+        $max_line_len = '-l2000,';
+    }
+
+    # This has to do the write itself, so we can't keep a lock. Life
+    # sucks.
+    my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input";
+    vprint 1, "Compiling...";
+    vprint 1, "Calling $command";
+
+	my ($output_r, $error_r) = spawnit($command);
+	my @output = @$output_r;
+	my @error = @$error_r;
+
+    if (@error && $? != 0) {
+        _die("$0: $Input did not compile, which can't happen:\n@error\n");
+    }
+
+    is_msvc ?
+        cc_harness_msvc($cfile,$stash) :
+        cc_harness($cfile,$stash) unless opt(c);
+
+    if ($lose) {
+        vprint 2, "unlinking $cfile";
+        unlink $cfile or _die("can't unlink $cfile: $!"); 
+    }
+}
+
+sub cc_harness_msvc {
+    my ($cfile,$stash)=@_;
+    use ExtUtils::Embed ();
+    my $obj = "${Output}.obj";
+    my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile ";
+    my $link = "-out:$Output $obj";
+    $compile .= " -I".$_ for split /\s+/, opt(I);
+    $link .= " -libpath:".$_ for split /\s+/, opt(L);
+    my @mods = split /-?u /, $stash;
+    $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
+    $link .= " perl5$Config{PERL_VERSION}.lib kernel32.lib msvcrt.lib";
+    vprint 3, "running $Config{cc} $compile";
+    system("$Config{cc} $compile");
+    vprint 3, "running $Config{ld} $link";
+    system("$Config{ld} $link");
+}
+
+sub cc_harness {
+	my ($cfile,$stash)=@_;
+	use ExtUtils::Embed ();
+	my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
+	$command .= " -I".$_ for split /\s+/, opt(I);
+	$command .= " -L".$_ for split /\s+/, opt(L);
+	my @mods = split /-?u /, $stash;
+	$command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
+        $command .= " -lperl";
+	vprint 3, "running $Config{cc} $command";
+	system("$Config{cc} $command");
+}
+
+# Where Perl is, and which include path to give it.
+sub yclept {
+    my $command = "$^X ";
+
+    # DWIM the -I to be Perl, not C, include directories.
+    if (opt(I) && $Backend eq "Bytecode") {
+        for (split /\s+/, opt(I)) {
+            if (-d $_) {
+                push @INC, $_;
+            } else {
+                warn "$0: Include directory $_ not found, skipping\n";
+            }
+        }
+    }
+            
+    $command .= "-I$_ " for @INC;
+    return $command;
+}
+
+# Use B::Stash to find additional modules and stuff.
+{
+    my $_stash;
+    sub grab_stash {
+
+        warn "already called get_stash once" if $_stash;
+
+        my $taint = opt(T) ? '-T' :
+                    opt(t) ? '-t' : '';
+        my $command = "$BinPerl $taint -MB::Stash -c $Input";
+        # Filename here is perfectly sanitised.
+        vprint 3, "Calling $command\n";
+
+		my ($stash_r, $error_r) = spawnit($command);
+		my @stash = @$stash_r;
+		my @error = @$error_r;
+
+    	if (@error && $? != 0) {
+            _die("$0: $Input did not compile:\n@error\n");
+        }
+
+        # band-aid for modules with noisy BEGIN {}
+        foreach my $i ( @stash ) {
+            $i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;
+            push @begin_output, $i;
+        }
+        chomp $stash[0];
+        $stash[0] =~ s/,-u\<none\>//;
+        $stash[0] =~ s/^.*?-u/-u/s;
+        vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
+        chomp $stash[0];
+        return $_stash = $stash[0];
+    }
+
+}
+
+# Check the consistency of options if -B is selected.
+# To wit, (-B|-O) ==> no -shared, no -S, no -c
+sub checkopts_byte {
+
+    _die("$0: Please choose one of either -B and -O.\n") if opt(O);
+
+    if (opt(shared)) {
+        warn "$0: Will not create a shared library for bytecode\n";
+        delete $Options->{shared};
+    }
+
+    for my $o ( qw[c S] ) { 
+        if (opt($o)) { 
+            warn "$0: Compiling to bytecode is a one-pass process--",
+                  "-$o ignored\n";
+            delete $Options->{$o};
+        }
+    }
+
+}
+
+# Check the input and output files make sense, are read/writeable.
+sub sanity_check {
+    if ($Input eq $Output) {
+        if ($Input eq 'a.out') {
+            _die("$0: Compiling a.out is probably not what you want to do.\n");
+            # You fully deserve what you get now. No you *don't*. typos happen.
+        } else {
+            warn "$0: Will not write output on top of input file, ",
+                "compiling to a.out instead\n";
+            $Output = "a.out";
+        }
+    }
+}
+
+sub check_read { 
+    my $file = shift;
+    unless (-r $file) {
+        _die("$0: Input file $file is a directory, not a file\n") if -d _;
+        unless (-e _) {
+            _die("$0: Input file $file was not found\n");
+        } else {
+            _die("$0: Cannot read input file $file: $!\n");
+        }
+    }
+    unless (-f _) {
+        # XXX: die?  don't try this on /dev/tty
+        warn "$0: WARNING: input $file is not a plain file\n";
+    } 
+}
+
+sub check_write {
+    my $file = shift;
+    if (-d $file) {
+        _die("$0: Cannot write on $file, is a directory\n");
+    }
+    if (-e _) {
+        _die("$0: Cannot write on $file: $!\n") unless -w _;
+    } 
+    unless (-w cwd()) { 
+        _die("$0: Cannot write in this directory: $!\n");
+    }
+}
+
+sub check_perl {
+    my $file = shift;
+    unless (-T $file) {
+        warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
+        print "Checking file type... ";
+        system("file", $file);  
+        _die("Please try a perlier file!\n");
+    } 
+
+    open(my $handle, "<", $file)    or _die("XXX: can't open $file: $!");
+    local $_ = <$handle>;
+    if (/^#!/ && !/perl/) {
+        _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n");
+    } 
+
+} 
+
+# File spawning and error collecting
+sub spawnit {
+	my ($command) = shift;
+	my (@error,@output);
+	my $errname;
+	(undef, $errname) = tempfile("pccXXXXX");
+	{ 
+	open (S_OUT, "$command 2>$errname |")
+		or _die("$0: Couldn't spawn the compiler.\n");
+	@output = <S_OUT>;
+	}
+	open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n");
+	@error = <S_ERROR>;
+	close S_ERROR;
+	close S_OUT;
+	unlink $errname or _die("$0: Can't unlink error file $errname");
+	return (\@output, \@error);
+}
+
+sub helpme {
+       print "perlcc compiler frontend, version $VERSION\n\n";
+       { no warnings;
+       exec "pod2usage $0";
+       exec "perldoc $0";
+       exec "pod2text $0";
+       }
+}
+
+sub relativize {
+	my ($args) = @_;
+
+	return() if ($args =~ m"^[/\\]");
+	return("./$args");
+}
+
+sub _die {
+    $logfh->print(@_) if opt('log');
+    print STDERR @_;
+    exit(); # should die eventually. However, needed so that a 'make compile'
+            # can compile all the way through to the end for standard dist.
+}
+
+sub _usage_and_die {
+    _die(<<EOU);
+$0: Usage:
+$0 [-o executable] [-r] [-O|-B|-c|-S] [-I /foo] [-L /foo] [-log log] [source[.pl] | -e oneliner]
+EOU
+}
+
+sub run {
+    my (@commands) = @_;
+
+    print interruptrun(@commands) if (!opt('log'));
+    $logfh->print(interruptrun(@commands)) if (opt('log'));
+}
+
+sub interruptrun
+{
+    my (@commands) = @_;
+
+    my $command = join('', @commands);
+    local(*FD);
+    my $pid = open(FD, "$command |");
+    my $text;
+    
+    local($SIG{HUP}) = sub { kill 9, $pid; exit };
+    local($SIG{INT}) = sub { kill 9, $pid; exit };
+
+    my $needalarm = 
+          ($ENV{PERLCC_TIMEOUT} && 
+	  $Config{'osname'} ne 'MSWin32' && 
+	  $command =~ m"(^|\s)perlcc\s");
+
+    eval 
+    {
+         local($SIG{ALRM}) = sub { die "INFINITE LOOP"; };
+         alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm);
+	 $text = join('', <FD>);
+	 alarm(0) if ($needalarm);
+    };
+
+    if ($@)
+    {
+        eval { kill 'HUP', $pid };
+        vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";
+    }
+
+    close(FD);
+    return($text);
+}
+
+sub is_win32() { $^O =~ m/^MSWin/ }
+sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
+
+END {
+    unlink $cfile if ($cfile && !opt(S) && !opt(c));
+}
+
+__END__
+
+=head1 NAME
+
+perlcc - generate executables from Perl programs
+
+=head1 SYNOPSIS
+
+    $ perlcc hello              # Compiles into executable 'a.out'
+    $ perlcc -o hello hello.pl  # Compiles into executable 'hello'
+
+    $ perlcc -O file            # Compiles using the optimised C backend
+    $ perlcc -B file            # Compiles using the bytecode backend
+
+    $ perlcc -c file            # Creates a C file, 'file.c'
+    $ perlcc -S -o hello file   # Creates a C file, 'file.c',
+                                # then compiles it to executable 'hello'
+    $ perlcc -c out.c file      # Creates a C file, 'out.c' from 'file'
+
+    $ perlcc -e 'print q//'     # Compiles a one-liner into 'a.out'
+    $ perlcc -c -e 'print q//'  # Creates a C file 'a.out.c'
+
+    $ perlcc -I /foo hello	# extra headers (notice the space after -I)
+    $ perlcc -L /foo hello	# extra libraries (notice the space after -L)
+
+    $ perlcc -r hello           # compiles 'hello' into 'a.out', runs 'a.out'.
+    $ perlcc -r hello a b c     # compiles 'hello' into 'a.out', runs 'a.out'.
+                                # with arguments 'a b c' 
+
+    $ perlcc hello -log c       # compiles 'hello' into 'a.out' logs compile
+                                # log into 'c'. 
+
+=head1 DESCRIPTION
+
+F<perlcc> creates standalone executables from Perl programs, using the
+code generators provided by the L<B> module. At present, you may
+either create executable Perl bytecode, using the C<-B> option, or 
+generate and compile C files using the standard and 'optimised' C
+backends.
+
+The code generated in this way is not guaranteed to work. The whole
+codegen suite (C<perlcc> included) should be considered B<very>
+experimental. Use for production purposes is strongly discouraged.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -LI<library directories>
+
+Adds the given directories to the library search path when C code is
+passed to your C compiler.
+
+=item -II<include directories>
+
+Adds the given directories to the include file search path when C code is
+passed to your C compiler; when using the Perl bytecode option, adds the
+given directories to Perl's include path.
+
+=item -o I<output file name>
+
+Specifies the file name for the final compiled executable.
+
+=item -c I<C file name>
+
+Create C code only; do not compile to a standalone binary.
+
+=item -e I<perl code>
+
+Compile a one-liner, much the same as C<perl -e '...'>
+
+=item -S
+
+Do not delete generated C code after compilation.
+
+=item -B
+
+Use the Perl bytecode code generator.
+
+=item -O
+
+Use the 'optimised' C code generator. This is more experimental than
+everything else put together, and the code created is not guaranteed to
+compile in finite time and memory, or indeed, at all.
+
+=item -v
+
+Increase verbosity of output; can be repeated for more verbose output.
+
+=item -r 
+
+Run the resulting compiled script after compiling it.
+
+=item -log
+
+Log the output of compiling to a file rather than to stdout.
+
+=back
+
+=cut
+
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/perldoc.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/perldoc.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/perldoc.bat	(revision 19631)
@@ -0,0 +1,27 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+    eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
+	if 0;
+
+# This "perldoc" file was generated by "perldoc.PL"
+
+require 5;
+BEGIN { $^W = 1 if $ENV{'PERLDOCDEBUG'} }
+use Pod::Perldoc;
+exit( Pod::Perldoc->run() );
+
+
+__END__
+:endofperl
Index: /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlglob.bat
===================================================================
--- /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlglob.bat	(revision 19631)
+++ /other-projects/trunk/realistic-books/bin/windows/perl/bin/perlglob.bat	(revision 19631)
@@ -0,0 +1,69 @@
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+use File::DosGlob;
+$| = 1;
+while (@ARGV) {
+    my $arg = shift;
+    my @m = File::DosGlob::doglob(1,$arg);
+    print (@m ? join("\0", sort @m) : $arg);
+    print "\0" if @ARGV;
+}
+__END__
+
+=head1 NAME
+
+perlglob.bat - a more capable perlglob.exe replacement
+
+=head1 SYNOPSIS
+
+    @perlfiles = glob  "..\\pe?l/*.p?";
+    print <..\\pe?l/*.p?>;
+
+    # more efficient version
+    > perl -MFile::DosGlob=glob -e "print <../pe?l/*.p?>"
+
+=head1 DESCRIPTION
+
+This file is a portable replacement for perlglob.exe.  It
+is largely compatible with perlglob.exe (the Microsoft setargv.obj
+version) in all but one respect--it understands wildcards in
+directory components.
+
+It prints null-separated filenames to standard output.
+
+For details of the globbing features implemented, see
+L<File::DosGlob>.
+
+While one may replace perlglob.exe with this, usage by overriding
+CORE::glob with File::DosGlob::glob should be much more efficient,
+because it avoids launching a separate process, and is therefore
+strongly recommended.  See L<perlsub> for details of overriding
+builtins.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy <gsar@activestate.com>
+
+=head1 SEE ALSO
+
+perl
+
+File::DosGlob
+
+=cut
+
+
+__END__
+:endofperl
