#! perl -w
#
#       Quick'n'Dirty Script to port libwww-perl-5 to Win 32 environment
#       and perl 5.001. Many NT users don't have a copy of the unix patch
#       program so this perl program does all that patch would do.
#       (of course, somebody could write a version of patch in perl)
#
#       Tested with Perl i386-107 from HIP communications. It would probably work
#       for other platforms that can't yet run 5.002, but I haven't tried it.
#
#       Acknowledgements go to Gisle Aas and others for such a wonderfully useful
#       piece of software.
#
#       Martin.Cleaver@bcs.org.com      Release 1.4     29/May/1996
#               This script may be distributed under the same terms and conditions
#               as Perl itself.
#
#       Unpack the Perl LWP archive, cd into it and run this script. It produces
#       a log file 'lwpWin32.log' in the current directory.
#               gzip -d libwww-perl-5_00_tar.gz
#               tar xf libwww-perl-5_00_tar
#               cd libwww-perl-5_00
#               perl ../lwpWin32.pl
#
#
#       This script patches files from the lib/ and bin/ directories downwards
#               removing dependencies on 'use vars'
#               replacing 'require 5.001' with 'require 5.002'
#               turning off use of alarms
#               overwriting LWP/IO.pm with a version that doesn't use select
#               invoking AutoSplit where necessary
#               This version of the script uses 'strict', so it produces some
#               warnings that don't seem to matter. (see below)

#  PROBLEMS and FIXES
#
#  1) Running LWP script might cause
#   'Error: Runtime exception Attempt to free unreferenced scalar during global destruction.'
#               at some awkward moments. This can be fixed by altering Symbol.pm
#               sub gensym {
#                  my $name = "GEN" . $genseq++;
#                  local *{$genpkg . $name};
#                  # \delete ${$genpkg}{$name};
#                  \${$genpkg}{$name};          # Memory leak now I presume, but doesn't
#               }                               # crash
#
#       AutoSplit.pm fails on Windows 95
#               I try to force a config option that isn't currently set for the Autosplit.
#               For some reason, this fails on a Win95 box, and files with long filenames get deleted
#               One solution is to edit Autosplit.pm and comment out the line:
#                  $maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
#
#       Autosplit will warn with complaints about writing to closed filehandle <OUT>
#       at (approximately 207). This is supposed to go to /dev/null but you can
#       patch perl5/lib/AutoSplit.pm to say
#          open(OUT,">/dev/null") || open(OUT,">nla0:") || open(OUT,">nul:"); # avoid 'not opened' warning
#       instead of
#          open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning
#
#       AutoSplit will warn about line 234 'use of uninitialised variable',
#       this doesn't seem to affect the result.
#
#       Possible improvements -
#          numerous!
#          could print out list of the files altered (but .old files
#               should make this  obvious
#          HIP should release 5.002 and be done with it.
#          binmode should be default or the parameter be required.
#               - there may be 'open' statements left in LWP that need
#                 fixing up.
#          If anyone knows how to eliminate the warnings or just general improvements
#          to this code, I would really like to include them.

package lwpWin32;
BEGIN
{
    unshift(@INC, 'lib');
}

use AutoSplit;
use strict;
$AutoSplit::Maxlen = 250;       # else we get errors on lib/URI/URL/_generic.pm
$AutoSplit::Verbose = 2;

use Config;
$Config::Config->{'d_flexfnam'} = 'define';     # so that Autosplit does not barf on long sub names.

my %done_file = ();

my %file = (                    # These need changing specifically.
        lwp_protocol_pm         => 'lib/LWP/Protocol.pm',
        lwp_socket_pm           => 'lib/LWP/Socket.pm',
        lwp_useragent_pm        => 'lib/LWP/UserAgent.pm',
        lwp_mediatypes_pm       => 'lib/LWP/MediaTypes.pm',
        lwp_io_pm               => 'lib/LWP/IO.pm',
        bin_lwp_mirror_pl       => 'bin/lwp-mirror.pl',
        bin_lwp_request_pl      => 'bin/lwp-request.pl',
        bin_lwp_rget_pl         => 'bin/lwp-rget.pl',
);
my $file;
foreach $file (keys %file) {
  $done_file{$file} =0;
}

my @manifest = read_manifest();
open_report();
edit_manifest_files();
edit_lwp_socket_pm();
edit_lwp_io_pm();
edit_bin_prog('bin_lwp_mirror_pl');
edit_bin_prog('bin_lwp_request_pl');
edit_bin_prog('bin_lwp_rget_pl');

check_home_var();
close_report();

#my $file;
foreach $file (sort keys %file) {
    if ($done_file{$file} != 1) {
        print "WARNING  - ".$file{$file}." edited $done_file{$file} times\n";
    } else {
        print "FIXED UP - ".$file{$file}." ok\n";
    }
}

exit 0;

sub open_report {
  open (REPORT, '>lwpWin32.log');
}

sub report {
  my $what = $_[0];
  print REPORT $what;
#  print $what;
}

sub close_report {
  close REPORT;
}

sub read_manifest {
  open (MANIFEST, "MANIFEST") || die "$!";
  my $line;
  my $description;
  my $file;
  my @manifest;
  while ($line = <MANIFEST>) {
    ($file,$description) = split(/\s/,$line);
    if ($file =~ m!lib/|bin/!) {
        push @manifest, $file;
    }
  }
  return @manifest;
}

sub check_home_var {
  if (!defined($ENV{'HOME'})) {
    report "You might want to set the HOME env var so that ".
          "$file{'lwp_mediatypes_pm'} does not complain\n";
  } else {
    $done_file{'lwp_mediatypes_pm'} ++;
  }
}

sub edit_bin_prog {
  my $file = $_[0];
  my $filename = $file{$file}; # Yuk!
  if (!open (ORIG, $filename)) {report "$filename - $!\n"; return;};
  my $line;
  my @prog;
  my $found = 'false';
  while ($line = <ORIG>) {
     if ($line =~ m/print OUT <<'!NO!SUBS!';/) {
        $found = 'true';
        last;
     }
  }
  while ($line = <ORIG>) {
     last if $line =~ m/^!NO!SUBS!/;
     push (@prog, $line);
  }
  close ORIG;
  if ($found ne 'true') {
        report "Eek - couldn't redo #! perl line in $filename\n";
        return;
  }

  open (NEW, '>'.$filename.'.new') || die $!;
  print NEW "#! perl -w\n";
  print NEW "\$DISTNAME = \"$filename-version_lwpwin32\";";
  print NEW @prog;
  close NEW;

  rename $filename.'.new', $filename;
  report "Rewritten $filename\n";
  $done_file{$file} ++;
}

# Open each file in the MANIFEST, replacing 5.002 and UNIXisms where necessary.
sub edit_manifest_files {
  my $file;
  my %replace_vars;
  my $buf;
  my $altered;
  my $package;
  my $line;
  my $copy;

  FILE:
  foreach $file (@manifest) {
      report "Searching $file\n";

      if (! open (FILE, $file)) {
         report "$file - $!\n";
         next FILE;
      }

      %replace_vars = ();
      $buf = '';
      $altered = 'no';
      $package = '';

      LINE:
      while ($line = <FILE>) {
        $copy = $line;
        $line =~ s/require 5.002/require 5.001/;

        $line =~ s/(sub [^\{]*?)\(.*?\)/$1/;

        $line =~ s/chomp(\$pwd = `pwd`);/use Cwd; \$pwd = cwd()/;

        if ($line =~ m/package (.*);/) {
          $package = $1;
        }


  # Turn all variables mentioned in 'use vars' statements into fully
  # qualified variables inside of the package. Seems to work ok. Needs
  # the $package variable defined.

        if ($line =~ m/use vars.*/) {
          if ($line !~ m/;$/) {
            while ($line .= <FILE>) {
              last if ($line =~ m/;/);
            }
          }
          $copy = $line;        # well, multiline
          $line =~ m/use vars *qw\(([\000-\377]*)\);/;  #m/use vars *(.*);/m;

          my $vars = $1;
          my $var_fq;
          my $var;
          my $sym;

  #       report "$file: has a 'use vars' line:\n$line\n\n";
  #       report "Line = '$line'\nVars  = '$vars'\n\n";

          $line = '';
          $vars =~ s/qw\((.*)\)/$1/m; # the string between ()'s, quoted.
          foreach $var (split(/\s+/, $vars)) {     # one char followed by a string
           # i.e. the $, %, or @ is the 1 character,
           #          sym        is the variable name.
            (undef,$sym) = unpack("a1a*", $var);
            $replace_vars{$sym} = $package.'::'.$sym;
            report "Replacing $sym => ".$replace_vars{$sym}."\n";
            $line .= "$var = undef; # Used at least twice\n"
          }
        }
  # End of replacing for 'use vars' statement.

  # Replace vars where they occur. Might do a bit more than necessary (ie comments)
  # This has yet to be a problem.
        my $var;
        foreach $var (keys %replace_vars) {
          $line =~ s/([^\s:])$var/$1$replace_vars{$var}/g;      # not if prefixed with whitespace or ::
        }


        if ($line =~ m/use Socket(.*)/)
        {
            while ($line .= <FILE>)
            {
              last if ($line =~ m/;/);
            }
            $copy = $line;  # well, multiline
      #     report "$file: has a 'use Socket' line:\n$line\n\n";
            $line =~ s/pack_sockaddr_in//;
            $line =~ s/unpack_sockaddr_in//;
            $line =~ s/inet_ntoa//;
            $line =~ s/inet_aton//;
        }

        if ($line =~ m/Socket->require_version(1.5)/)
        {
            next;           # Version line not defined in distribution,
        }


        if ($file eq $file{'lwp_useragent_pm'})
        {
           if ($line =~ m/'use_alarm'\s*\=\>\s1.*/)
           {
              $line =~ s/1/0/;
              report "Disabled alarms by default\n";
              $done_file{'lwp_useragent_pm'} ++;
           }
        }

  #      if ($line =~ m/open\s*\(?(\w).*/) {    # This doesn't work, need something
  #     $filehandle = $1;                       # more specific.
  #     if ($line !~ m/;$/) {
  #       while ($line .= <FILE>) {
  #         last if ($line =~ m/;/);
  #       }
  #     }
  #     $copy = $line;  # well, multiline
  #     $line .= "\nbinmode($filehandle);\n";   # Doesn't hurt to do it more than once :^)
  #     }

        if ($file eq $file{'lwp_protocol_pm'}) {
          if ($line =~ m/open\(OUT/    ) {
            if ($line !~ m/;$/) {
              while ($line .= <FILE>) {
                last if ($line =~ m/;/);
              }
            }
            $copy = $line;      # well, multiline
            $line .= "\nbinmode(OUT);\n";       # Doesn't hurt to do it more than once :^)
            $done_file{'lwp_protocol_pm'} ++;
          }
        }

        if ($line ne $copy) {
          report "$file: altered \n\t'$copy' to \n\t'$line'\n";
          $altered = 'yes';
        }
        $buf .= $line;
      }
      close FILE;
      if ($altered eq 'yes') {
#       report "$buf\n"; next FILE; # DEBUGGING CODE.

        report "\n\nWriting $file\n";
#       report "$buf\n";
        rename $file, $file.'.old' || die "$!";
        if (!open (FILE, '>'.$file)) {
           report "Can't write $file - $!\n";
           next FILE;
        }
        print FILE $buf;
        close FILE;
      }

      report "\t\t\t\t";
      if ($file =~ m/pm$/) {
        autosplit_lib_modules($file);
      } else {
        report "\n";
      }

  }
  report "\n";
}

sub edit_lwp_socket_pm {
  my $win32_id = "# \$Id: $file{'lwp_socket_pm'} - Win32 mrjc \$";

  if (!open (SOCKET_PM, $file{'lwp_socket_pm'}) ) {
    report "$file{'lwp_socket_pm'} - $!\n";
    return;
  }
  my @code = <SOCKET_PM>;
  close SOCKET_PM;

  my $found_end='false';
  my $id_line = $code[0];
  chomp($id_line);
  #report "ID line ='$id_line'\nCk line ='$win32_id'\n";
  if ($id_line ne $win32_id) {
    report "Rewriting $file{'lwp_socket_pm'} ...";
    open (NEW_SOCKET_PM, '>'.$file{'lwp_socket_pm'}.'.new' ) || die "$!";
    print NEW_SOCKET_PM $win32_id."\n";

    my $found_end = 'false';
    my $line;
    foreach $line (@code) {
        next if ($line =~ m/Socket->require_version/);

        if ($line =~ m/^__END__$/) {
            print NEW_SOCKET_PM "\n #Begin patch for Win32\n";
            print NEW_SOCKET_PM win32_code();
            print NEW_SOCKET_PM "\n#End patch for Win32\n";
            report "\tfound it!\n";
            $found_end='true';
        }
        if ($line =~ m/^&chargen;$/) {
            $line = 'print "This is NT\n"'.";\n";
            $line .= '#'.$line;
        }
        if ($line =~ m/^&echo;$/) {
            $line = '#'.$line;
            $line .= "&http();\n";
        }
        print NEW_SOCKET_PM $line;
    }
    print NEW_SOCKET_PM http_test_code();
    close NEW_SOCKET_PM;

    if ($found_end eq 'true') {
        report "\t$file{'lwp_socket_pm'} fixed\n";
        rename $file{'lwp_socket_pm'}, $file{'lwp_socket_pm'}.'.old' || die "$!";
        rename $file{'lwp_socket_pm'}.'.new', $file{'lwp_socket_pm'} || die "$!";
        $done_file{'lwp_socket_pm'} ++;
    } else {
        report "\t$file{'lwp_socket_pm'} - COULDN'T FIND __END__ token\n";
    }
  } else {
   report "$file{'lwp_socket_pm'} already done\n";
  }
}

sub edit_lwp_io_pm {
  rename $file{'lwp_io_pm'}, $file{'lwp_io_pm'}.'old';
  if (!open (LWP_IO_PM, '>'.$file{'lwp_io_pm'})) {report "$file{'lwp_io_pm'} - $!\n"; return;}
  print LWP_IO_PM lwp_io_code();
  close LWP_IO_PM;
  report "Rewrote $file{'lwp_io_pm'}\n";
  autosplit_lib_modules($file{'lwp_io_pm'});
  $done_file{'lwp_io_pm'} ++;
}

# ------------------------------------------------------------------------

sub win32_code {
my $addit = <<'EOM';
BEGIN {
  if (!defined &sockaddr_in) {

     my $nt_compat = <<'EOT';

  # Of course, this lot should be added to lib/Socket.pm as supplied from HIP
  sub LWP::Socket::pack_sockaddr_in {
        my ($port, $addr) = @_;
        my (@addr) = unpack('C4', $addr);
        my $pf_inet = 2;                                # PF_INET
#       print "$port,". LWP::Socket::inet_ntoa($addr);
        return pack("S n C4 x8", $pf_inet, $port, @addr);
  }

  sub LWP::Socket::inet_aton {return pack('C4',split(/\./, $_[0]))};
  sub LWP::Socket::inet_ntoa {return join(".", unpack('C4', @_))};
  sub LWP::Socket::unpack_sockaddr_in {print "unpack @_\n"; my ($family, $port, $addr) = unpack('S n C4 x8', @_); return ($port, $addr) }; #  unpack...

EOT

  eval $nt_compat;

  } # End BEGIN
}
EOM

return $addit;
}

sub lwp_io_code {
my $addit = <<'EOM';
package LWP::IO;

# $Id: IO.pm,v 1.7 1996/04/09 15:44:26 aas Exp $

require LWP::Debug;
use AutoLoader;
@ISA=qw(AutoLoader);

sub read;
sub write;

1;
__END__

=head1 NAME

LWP::IO - Low level I/O capability

=head1 DESCRIPTION

=head2 LWP::IO::read($fd, $data, $size, $offset, $timeout)

=head2 LWP::IO::write($fd, $data, $timeout)

These routines provide low level I/O with timeout capability for the
LWP library.  These routines will only be installed if they are not
already defined.  This fact can be used by programs that need to
override these functions.  Just provide replacement functions before
you require LWP. See also L<LWP::TkIO>.

=cut

sub read
{
    my $fd      = shift;
    # data is now $_[0]
    my $size    = $_[1];
    my $offset  = $_[2] || 0;
    my $timeout = $_[3];

    my $rin = '';
    vec($rin, fileno($fd), 1) = 1;
    my $err = "";   #Thou shall not use Timeouts
    my $nfound = 2; # select($rin, undef, $err = $rin, 0);      # $timeout
#    my $err;
#    my $nfound = select($rin, undef, $err = $rin, $timeout);
    if ($nfound == 0) {
        die "Timeout";
    } elsif ($nfound < 0) {
        die "Select failed: $!";
    } elsif ($err =~ /[^\0]/) {
        die "Exception while reading on socket handle";
    } else {
        my $n = sysread($fd, $_[0], $size, $offset);
        # Since so much data might pass here we cheat about debugging
        if ($LWP::Debug::current_level{'conns'}) {
            LWP::Debug::debug("Read $n bytes");
            LWP::Debug::conns($_[0]) if $n;
        }
        return $n;
    }
}

sub write
{
    my $fd = shift;
    my $timeout = $_[1];  # we don't want to copy data in $_[0]

    my $len = length $_[0];
    my $offset = 0;
    while ($offset < $len) {
        my $win = '';
        vec($win, fileno($fd), 1) = 1;
        my $err = "";    #Thou shall not use Timeouts
        my $nfound = 2 ; #select(undef, $win, $err = $win, $timeout);
#        my $err;
#        my $nfound = select(undef, $win, $err = $win, $timeout);
        if ($nfound == 0) {
            die "Timeout";
        } elsif ($nfound < 0) {
            die "Select failed: $!";
        } elsif ($err =~ /[^\0]/) {
            die "Exception while writing on socket handle";
        } else {
            my $n = syswrite($fd, $_[0], $len-$offset, $offset);
            return $bytes_written unless defined $n;

            if ($LWP::Debug::current_level{'conns'}) {
                LWP::Debug::conns("Write $n bytes: '" .
                                  substr($_[0], $offset, $n) .
                                  "'");
            }
            $offset += $n;
        }
    }
    $offset;
}

1;
EOM
return $addit;
}

sub http_test_code {
my $addit = <<'EOM';

sub http
{
    $socket = new LWP::Socket;
    $socket->connect('www', 80); # http

    select($socket->{'socket'});$|=1;
    select(STDOUT);
    $socket->write("GET /\r\n\r\n");
    $socket->read_until("\n", \$buffer);
    print "$buffer\n";
}
EOM

return $addit;
}