PATCH: LWPng-alpha on Windows NT
Blair Zajac (blair@gps.caltech.edu)
Thu, 2 Jul 1998 23:39:46 -0700 (PDT)
Hi,
I've completed porting LWPng-alpha to Windows NT. I'm including below the
complete patch for LWPng-alpha 0.21. It fixes a few things:
1) Add LWP::Extras that calculates EINPROGRESS and defines
IO::Handle::blocking.
2) Replace the EINPROGRESS and IO::Handle::blocking code from LWP::Conn::HTTP
and LWP::Conn::_Connet with use LWP::Extras.
3) Have LWPng-alpha/Makefile.PL require LWP 5.33.
4) In LWP::Conn::FILE test for the existence of getpwuid and getgrgid. These
were causing the main failures of LWPng on NT.
Gisle, again, could you put out a new LWPng-alpha 0.22 release soon? I'm
releasing another package that will need these patches installed and
these patches will also allow WebFS::FileCopy to work on NT.
Thanks,
Blair
cd LWPng-alpha-0.21
mkdir Extras
exit 0
diff -rcN ../LWPng-alpha-0.21-orig/Extras/Extras.pm ./Extras/Extras.pm
*** ../LWPng-alpha-0.21-orig/Extras/Extras.pm Wed Dec 31 17:00:00 1969
--- ./Extras/Extras.pm Thu Jul 2 23:38:01 1998
***************
*** 0 ****
--- 1,132 ----
+ package LWP::Extras;
+
+ use strict;
+ use vars qw($VERSION @ISA);
+
+ use Exporter;
+ use DynaLoader;
+ use IO::Handle;
+
+ @ISA = qw(Exporter DynaLoader);
+ $VERSION = '0.01';
+
+ # Here we load the constant subroutines from the XS module.
+ bootstrap LWP::Extras $VERSION;
+
+ # Here we define the subroutine IO::EINPROGRESS and emulate the
+ # $handle->blocking call provided by newer versions of the IO
+ # module. This will not be needed when we require IO-1.18 or
+ # greater.
+
+ # &IO::EINPROGRESS is not defined in IO versions older than 1.18.
+ unless (defined &IO::EINPROGRESS) {
+ my $einprogress = -1;
+
+ if (defined &LWP::Extras::EINPROGRESS) {
+ # Try to use LWP::Extras::EINPROGRESS.
+ $einprogress = &LWP::Extras::EINPROGRESS;
+ }
+ else {
+ # Otherwise try to use POSIX.
+ eval {
+ require POSIX;
+ $einprogress = &POSIX::EINPROGRESS;
+ };
+ $! = $einprogress;
+ die "The system constant EINPROGRESS cannot be found ($!)" if ($@ or $! ne "Operation now in progress");
+ }
+ *IO::EINPROGRESS = sub () { $einprogress; };
+ }
+
+ # Emulate $handle->blocking call provided by newer versions of the IO modules.
+ unless (defined &IO::Handle::blocking) {
+ my ($O_NONBLOCK, $F_GETFL, $F_SETFL);
+ eval {
+ require Fcntl;
+ $O_NONBLOCK = Fcntl::O_NONBLOCK();
+ $F_GETFL = Fcntl::F_GETFL();
+ $F_SETFL = Fcntl::F_SETFL();
+ };
+ unless ($@) {
+ # We got the Fcntl constants OK.
+ *IO::Handle::blocking = sub {
+ my $fh = shift;
+ my $dummy = '';
+ my $old = fcntl($fh, $F_GETFL, $dummy);
+ return unless defined $old;
+ if (@_) {
+ my $new = $old;
+ if ($_[0]) {
+ $new &= ~$O_NONBLOCK;
+ } else {
+ $new |= $O_NONBLOCK;
+ }
+ fcntl($fh, $F_SETFL, $new);
+ }
+ ($old & $O_NONBLOCK) == 0;
+ }
+ }
+ else {
+ # We do not have Fcntl constants. We'll implement the blocking
+ # method call but it will not do anything.
+ *IO::Handle::blocking = sub {
+ return;
+ }
+ }
+ }
+
+
+ 1;
+
+ __END__
+
+ =pod
+
+ =head1 NAME
+
+ LWP::Extras - Create IO capabilites for older Perls
+
+ =head1 SYNOPSIS
+
+ use LWP::Extras;
+ print LWP::Extras::EINPROGRESS;
+ $handle->blocking(0);
+
+ =head1 DESCRIPTION
+
+ LWP::Extras is used to set up some IO specific constants and method
+ calls for Perls using older versions of the IO libraries. If the
+ IO::EINPROGRESS constant subroutine does not exist, then this module
+ will attempt to calculate the correct value for the EINPROGRESS
+ error return from a socket call and also set up the I<blocking>
+ method call for file handles. EINPROGRESS is found from the XS
+ module that comes with this module or, if that does not work, from
+ the POSIX module. If EINPROGRESS cannot be determined, the module
+ dies.
+
+ On Windows 32 systems which define WSAEINPROGRESS, WSAEINPROGRESS
+ is used instead of EINPROGRESS.
+
+ If the system has the NON_BLOCK, F_GETFL and F_SETFL constants from the
+ Fcntl module, then the IO::Handle::blocking method call will exist
+ and either turn on or off blocking and return the old setting for
+ blocking. If there is an error or the system does not have the Fcntl
+ constants, then it returns an empty list in a list context, an undefined
+ value in a scalar context, or nothing in a void context.
+
+ =head1 AUTHOR
+
+ Blair Zajac, blair@gps.caltech.edu.
+
+ =head1 SEE ALSO
+
+ See also L<LWP::MainLoop> and L<IO::Handle>.
+
+ =head1 COPYRIGHT
+
+ (C) Copyright 1998 by Blair Zajac.
+
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+ =cut
diff -rcN ../LWPng-alpha-0.21-orig/Extras/Extras.xs ./Extras/Extras.xs
*** ../LWPng-alpha-0.21-orig/Extras/Extras.xs Wed Dec 31 17:00:00 1969
--- ./Extras/Extras.xs Thu Jul 2 23:34:01 1998
***************
*** 0 ****
--- 1,97 ----
+ /*
+ * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>.
+ * Copyright (c) 1998 Blair Zajac <blair@gps.caltech.edu>.
+ * All rights reserved. This program is free software; you can
+ * redistribute it and/or modify it under the same terms as Perl itself.
+ */
+
+ #ifdef __cplusplus
+ extern "C" {
+ #endif
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ #include "patchlevel.h"
+ #ifdef __cplusplus
+ }
+ #endif
+
+
+ #if (PATCHLEVEL < 3) || ((PATCHLEVEL == 3) && (SUBVERSION < 22))
+ /* before 5.003_22 */
+ # define MY_start_subparse(fmt,flags) start_subparse()
+ #else
+ # if (PATCHLEVEL == 3) && (SUBVERSION == 22)
+ /* 5.003_22 */
+ # define MY_start_subparse(fmt,flags) start_subparse(flags)
+ # else
+ /* 5.003_23 onwards */
+ # define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
+ # endif
+ #endif
+
+ #ifndef gv_stashpvn
+ #define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+ #endif
+
+ #ifndef newCONSTSUB
+ /*
+ * Define an XSUB that returns a constant scalar. The resulting structure is
+ * identical to that created by the parser when it parses code like :
+ *
+ * sub xyz () { 123 }
+ *
+ * This allows the constants from the XSUB to be inlined.
+ *
+ */
+
+ static void
+ newCONSTSUB(stash,name,sv)
+ HV *stash;
+ char *name;
+ SV *sv;
+ {
+ #ifdef dTHR
+ dTHR;
+ #endif
+ U32 oldhints = hints;
+ HV *old_cop_stash = curcop->cop_stash;
+ HV *old_curstash = curstash;
+ line_t oldline = curcop->cop_line;
+ curcop->cop_line = copline;
+
+ hints &= ~HINT_BLOCK_SCOPE;
+ if(stash)
+ curstash = curcop->cop_stash = stash;
+
+ newSUB(
+ MY_start_subparse(FALSE, 0),
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &sv_no), /* SvPV(&sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ hints = oldhints;
+ curcop->cop_stash = old_cop_stash;
+ curstash = old_curstash;
+ curcop->cop_line = oldline;
+ }
+ #endif
+
+ MODULE = LWP::Extras PACKAGE = LWP::Extras
+
+ BOOT:
+ {
+ HV *stash;
+ /*
+ * Declare constant subroutines.
+ */
+ stash = gv_stashpvn("LWP::Extras", 11, TRUE);
+ #ifdef WSAEINPROGRESS
+ #undef EINPROGRESS
+ #define EINPROGRESS (WSAEINPROGRESS)
+ #endif
+ #ifdef EINPROGRESS
+ newCONSTSUB(stash, "EINPROGRESS", newSViv(EINPROGRESS));
+ #endif
+ }
diff -rcN ../LWPng-alpha-0.21-orig/Extras/MANIFEST ./Extras/MANIFEST
*** ../LWPng-alpha-0.21-orig/Extras/MANIFEST Wed Dec 31 17:00:00 1969
--- ./Extras/MANIFEST Wed Jul 1 15:29:55 1998
***************
*** 0 ****
--- 1,5 ----
+ Extras.pm
+ Extras.xs
+ MANIFEST
+ Makefile.PL
+ t/01extras.t
diff -rcN ../LWPng-alpha-0.21-orig/Extras/Makefile.PL ./Extras/Makefile.PL
*** ../LWPng-alpha-0.21-orig/Extras/Makefile.PL Wed Dec 31 17:00:00 1969
--- ./Extras/Makefile.PL Mon Jun 29 20:37:17 1998
***************
*** 0 ****
--- 1,7 ----
+ use ExtUtils::MakeMaker;
+ # See lib/ExtUtils/MakeMaker.pm for details of how to influence
+ # the contents of the Makefile that is written.
+ WriteMakefile(
+ 'NAME' => 'LWP::Extras',
+ 'VERSION_FROM' => 'Extras.pm', # finds $VERSION
+ );
diff -rcN ../LWPng-alpha-0.21-orig/Extras/t/01extras.t ./Extras/t/01extras.t
*** ../LWPng-alpha-0.21-orig/Extras/t/01extras.t Wed Dec 31 17:00:00 1969
--- ./Extras/t/01extras.t Wed Jul 1 15:46:58 1998
***************
*** 0 ****
--- 1,34 ----
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ use strict;
+ use vars qw($loaded);
+ BEGIN { $| = 1; print "1..5\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+
+ my $ok_count = 1;
+ sub ok {
+ shift or print "not ";
+ print "ok $ok_count\n";
+ ++$ok_count;
+ }
+
+ use LWP::Extras;
+ $loaded = 1;
+ ok(1); # 1
+
+ ######################### End of black magic.
+
+ # Insert your test code below (better if it prints "ok 13"
+ # (correspondingly "not ok 13") depending on the success of chunk 13
+ # of the test code):
+
+ ok( defined &LWP::Extras::EINPROGRESS ); # 2
+ ok( defined &IO::EINPROGRESS ); # 3
+ ok( &IO::EINPROGRESS ); # 4
+ ok( defined &IO::Handle::blocking ); # 5
diff -rcN ../LWPng-alpha-0.21-orig/MANIFEST ./MANIFEST
*** ../LWPng-alpha-0.21-orig/MANIFEST Sat Jun 27 02:31:23 1998
--- ./MANIFEST Wed Jul 1 15:52:07 1998
***************
*** 12,17 ****
--- 12,22 ----
bot/dbclear
bot/dblist
bot/ngbot
+ Extras/Extras.pm
+ Extras/Extras.xs
+ Extras/MANIFEST
+ Extras/Makefile.PL
+ Extras/t/01extras.t
lib/LWP/Authen.pm
lib/LWP/Authen/basic.pm
lib/LWP/Authen/digest.pm
diff -rcN ../LWPng-alpha-0.21-orig/Makefile.PL ./Makefile.PL
*** ../LWPng-alpha-0.21-orig/Makefile.PL Fri Apr 24 01:19:17 1998
--- ./Makefile.PL Wed Jul 1 14:44:10 1998
***************
*** 4,9 ****
WriteMakefile(
NAME => "LWPng-alpha",
VERSION_FROM => "lib/LWP/Version.pm",
! PREREQ_PM => { LWP => '5.32', },
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz'},
);
--- 4,9 ----
WriteMakefile(
NAME => "LWPng-alpha",
VERSION_FROM => "lib/LWP/Version.pm",
! PREREQ_PM => { LWP => '5.33', },
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz'},
);
diff -rcN ../LWPng-alpha-0.21-orig/lib/LWP/Conn/FILE.pm ./lib/LWP/Conn/FILE.pm
*** ../LWPng-alpha-0.21-orig/lib/LWP/Conn/FILE.pm Fri Apr 24 01:04:42 1998
--- ./lib/LWP/Conn/FILE.pm Thu Jul 2 15:31:23 1998
***************
*** 9,14 ****
--- 9,20 ----
use HTTP::Date qw(time2str str2time);
use LWP::MediaTypes qw(guess_media_type);
+ # Test to see if the system has getpwuid and getgrgid.
+ eval { my $tmp = getpwuid($<); };
+ my $has_getpwuid = ! $@;
+ eval { my $tmp = getgrgid($(); };
+ my $has_getgrgid = ! $@;
+
sub new
{
my($class, %cnf) = @_;
***************
*** 87,94 ****
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
$atime,$mtime,$ctime,$blksize,$blocks) = stat(FILE);
! my $uname = getpwuid($uid) || $uid;
! my $gname = getgrgid($gid) || $gid;
# far more than you ever wanted to know
$res->header("INode" => sprintf("[%04x]:%d", $dev, $ino)) if $ino;
--- 93,100 ----
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
$atime,$mtime,$ctime,$blksize,$blocks) = stat(FILE);
! my $uname = ($has_getpwuid ? getpwuid($uid) : undef) || $uid;
! my $gname = ($has_getgrgid ? getgrgid($gid) : undef) || $gid;
# far more than you ever wanted to know
$res->header("INode" => sprintf("[%04x]:%d", $dev, $ino)) if $ino;
diff -rcN ../LWPng-alpha-0.21-orig/lib/LWP/Conn/HTTP.pm ./lib/LWP/Conn/HTTP.pm
*** ../LWPng-alpha-0.21-orig/lib/LWP/Conn/HTTP.pm Sat Jun 27 02:21:09 1998
--- ./lib/LWP/Conn/HTTP.pm Mon Jun 29 21:23:45 1998
***************
*** 7,56 ****
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
- # A hack that should work at least on systems with POSIX.pm. It
- # implements the constant EINPROGRESS and IO::Handle->blocking;
- # XXX: When we require IO-1.18, then this hack can be removed.
- require IO::Handle;
- unless (defined &IO::EINPROGRESS) {
- my $einprogress = -1;
- eval {
- require POSIX;
- $einprogress = &POSIX::EINPROGRESS;
- };
- $! = $einprogress;
- die "No EINPROGRESS found ($!)" if ($@ or $! ne "Operation now in progress");
- *IO::EINPROGRESS = sub () { $einprogress; };
-
- # we also emulate $handle->blocking call provided by newer versions of
- # the IO modules
- require Fcntl;
- my $O_NONBLOCK = Fcntl::O_NONBLOCK();
- my $F_GETFL = Fcntl::F_GETFL();
- my $F_SETFL = Fcntl::F_SETFL();
- *IO::Handle::blocking = sub {
- my $fh = shift;
- my $dummy = '';
- my $old = fcntl($fh, $F_GETFL, $dummy);
- return undef unless defined $old;
- if (@_) {
- my $new = $old;
- if ($_[0]) {
- $new &= ~$O_NONBLOCK;
- } else {
- $new |= $O_NONBLOCK;
- }
- fcntl($fh, $F_SETFL, $new);
- }
- ($old & $O_NONBLOCK) == 0;
- }
- }
-
use strict;
use vars qw($DEBUG);
use vars qw(@TE);
@TE = qw(deflate base64 rot13);
my $TCP_PROTO = (getprotobyname('tcp'))[2];
use Carp ();
use IO::Socket qw(AF_INET SOCK_STREAM inet_aton pack_sockaddr_in);
use LWP::MainLoop qw(mainloop);
--- 7,19 ----
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
use strict;
use vars qw($DEBUG);
use vars qw(@TE);
@TE = qw(deflate base64 rot13);
my $TCP_PROTO = (getprotobyname('tcp'))[2];
+ use LWP::Extras;
use Carp ();
use IO::Socket qw(AF_INET SOCK_STREAM inet_aton pack_sockaddr_in);
use LWP::MainLoop qw(mainloop);
diff -rcN ../LWPng-alpha-0.21-orig/lib/LWP/Conn/_Connect.pm ./lib/LWP/Conn/_Connect.pm
*** ../LWPng-alpha-0.21-orig/lib/LWP/Conn/_Connect.pm Sat Jun 27 02:21:09 1998
--- ./lib/LWP/Conn/_Connect.pm Mon Jun 29 21:25:12 1998
***************
*** 7,53 ****
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
-
use strict;
use vars qw($DEBUG @ISA);
!
! # A hack that should work at least on systems with POSIX.pm. It
! # implements the constant EINPROGRESS and IO::Handle->blocking;
! # XXX: When we require IO-1.18, then this hack can be removed.
! require IO::Handle;
! unless (defined &IO::EINPROGRESS) {
! my $einprogress = -1;
! eval {
! require POSIX;
! $einprogress = &POSIX::EINPROGRESS;
! };
! $! = $einprogress;
! die "No EINPROGRESS found ($!)" if ($@ or $! ne "Operation now in progress!
! *IO::EINPROGRESS = sub () { $einprogress; };
!
! # we also emulate $handle->blocking call provided by newer versions of
! # the IO modules
! require Fcntl;
! my $O_NONBLOCK = Fcntl::O_NONBLOCK();
! my $F_GETFL = Fcntl::F_GETFL();
! my $F_SETFL = Fcntl::F_SETFL();
! *IO::Handle::blocking = sub {
! my $fh = shift;
! my $dummy = '';
! my $old = fcntl($fh, $F_GETFL, $dummy);
! return undef unless defined $old;
! if (@_) {
! my $new = $old;
! if ($_[0]) {
! $new &= ~$O_NONBLOCK;
! } else {
! $new |= $O_NONBLOCK;
! }
! fcntl($fh, $F_SETFL, $new);
! }
! ($old & $O_NONBLOCK) == 0;
! }
! }
my $TCP_PROTO = (getprotobyname('tcp'))[2];
use Carp ();
--- 7,15 ----
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
use strict;
use vars qw($DEBUG @ISA);
! use LWP::Extras;
my $TCP_PROTO = (getprotobyname('tcp'))[2];
use Carp ();