From: Tye McQueen <tye@metronet.com>
Date: Sun, 4 Jan 1998 00:30:57 +0000 (-0600)
Subject: [win32] Add a tweaked version of:
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=22fae026e9f4859841088a1c5609be12b0b1d4f3;p=p5sagit%2Fp5-mst-13.2.git

[win32] Add a tweaked version of:
	Message-Id: <199801040630.AA29298@metronet.com>
	Subject: New patch for $^E==GetLastError() under Win32

p4raw-id: //depot/win32/perl@392
---

diff --git a/doio.c b/doio.c
index cd718a9..dce271d 100644
--- a/doio.c
+++ b/doio.c
@@ -500,7 +500,8 @@ nextargv(register GV *gv)
 	    return IoIFP(GvIOp(gv));
 	}
 	else
-	    PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",SvPV(sv, na), Strerror(errno));
+	    PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
+	      SvPV(sv, na), Strerror(errno));
     }
     if (inplace) {
 	(void)do_close(argvoutgv,FALSE);
diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl
index c32bc2f..cc7da89 100644
--- a/lib/dumpvar.pl
+++ b/lib/dumpvar.pl
@@ -22,6 +22,7 @@ $printUndef = 1 unless defined $printUndef;
 $tick = "auto" unless defined $tick;
 $unctrl = 'quote' unless defined $unctrl;
 $subdump = 1;
+$dumpReused = 0 unless defined $dumpReused;
 
 sub main::dumpValue {
   local %address;
@@ -118,7 +119,7 @@ sub unwrap {
     # Check for reused addresses
     if (ref $v) { 
       ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; 
-      if (defined $address) { 
+      if (!$dumpReused && defined $address) { 
 	($type) = $v =~ /=(.*?)\([^=]+$/ ;
 	$address{$address}++ ;
 	if ( $address{$address} > 1 ) { 
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index ea072e0..f0774bc 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -173,7 +173,7 @@ $trace = $signal = $single = 0;	# Uninitialized warning suppression
                                 # (local $^W cannot help - other packages!).
 $inhibit_exit = $option{PrintRet} = 1;
 
-@options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages 
+@options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
 		  compactDump veryCompact quote HighBit undefPrint
 		  globPrint PrintRet UsageOnly frame AutoTrace
 		  TTY noTTY ReadLine NonStop LineInfo maxTraceLen
@@ -185,6 +185,7 @@ $inhibit_exit = $option{PrintRet} = 1;
 		 arrayDepth	=> \$dumpvar::arrayDepth,
 		 DumpDBFiles	=> \$dumpvar::dumpDBFiles,
 		 DumpPackages	=> \$dumpvar::dumpPackages,
+		 DumpReused	=> \$dumpvar::dumpReused,
 		 HighBit	=> \$dumpvar::quoteHighBit,
 		 undefPrint	=> \$dumpvar::printUndef,
 		 globPrint	=> \$dumpvar::globPrint,
@@ -368,7 +369,7 @@ sub DB {
     &save;
     ($package, $filename, $line) = caller;
     $filename_ini = $filename;
-    $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
+    $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
       "package $package;";	# this won't let them modify, alas
     local(*dbline) = $main::{'_<' . $filename};
     $max = $#dbline;
@@ -1140,7 +1141,7 @@ EOP
 	  &eval;
 	}
     }				# if ($single || $signal)
-    ($@, $!, $,, $/, $\, $^W) = @saved;
+    ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
     ();
 }
 
@@ -1190,7 +1191,7 @@ sub sub {
 }
 
 sub save {
-    @saved = ($@, $!, $,, $/, $\, $^W);
+    @saved = ($@, $!, $^E, $,, $/, $\, $^W);
     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
 }
 
@@ -1210,7 +1211,7 @@ sub eval {
     }
     my $at = $@;
     local $saved[0];		# Preserve the old value of $@
-    eval "&DB::save";
+    eval { &DB::save };
     if ($at) {
 	print $OUT $at;
     } elsif ($onetimeDump eq 'dump') {
@@ -1785,6 +1786,7 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
     I<globPrint>:			whether to print contents of globs;
     I<DumpDBFiles>:		dump arrays holding debugged files;
     I<DumpPackages>:		dump symbol tables of packages;
+    I<DumpReused>:		dump contents of \"reused\" addresses;
     I<quote>, I<HighBit>, I<undefPrint>:	change style of string dump;
   Option I<PrintRet> affects printing of return value after B<r> command,
          I<frame>    affects printing messages on entry and exit from subroutines.
diff --git a/mg.c b/mg.c
index b032bf3..1d00143 100644
--- a/mg.c
+++ b/mg.c
@@ -69,7 +69,6 @@ restore_magic(void *p)
     }
 }
 
-
 void
 mg_magical(SV *sv)
 {
@@ -350,10 +349,22 @@ magic_get(SV *sv, MAGIC *mg)
 	    sv_setpv(sv, os2error(Perl_rc));
 	}
 #else
+#ifdef WIN32
+	{
+	    DWORD dwErr = GetLastError();
+	    sv_setnv(sv, (double)dwErr);
+	    if (dwErr)
+		win32_str_os_error(sv, dwErr);
+	    else
+		sv_setpv(sv, "");
+	    SetLastError(dwErr);
+	}
+#else
 	sv_setnv(sv, (double)errno);
 	sv_setpv(sv, errno ? Strerror(errno) : "");
 #endif
 #endif
+#endif
 	SvNOK_on(sv);	/* what a wonderful hack! */
 	break;
     case '\006':		/* ^F */
@@ -1349,9 +1360,13 @@ magic_set(SV *sv, MAGIC *mg)
 #ifdef VMS
 	set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 #else
+#ifdef WIN32
+	SetLastError( SvIV(sv) );
+#else
 	/* will anyone ever use this? */
 	SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
 #endif
+#endif
 	break;
     case '\006':	/* ^F */
 	maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
diff --git a/perl.h b/perl.h
index 59d7293..9138ba6 100644
--- a/perl.h
+++ b/perl.h
@@ -1666,6 +1666,10 @@ struct perl_thread {
 #include "thrdvar.h"
 };
 
+typedef struct perl_thread *Thread;
+
+#else
+typedef void *Thread;
 #endif
 
 /* Done with PERLVAR macros for now ... */
@@ -1673,8 +1677,6 @@ struct perl_thread {
 #undef PERLVARI
 #undef PERLVARIC
 
-typedef struct perl_thread *Thread;
-
 #include "thread.h"
 #include "pp.h"
 #include "proto.h"
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 49d455b..a89ee99 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -1,3 +1,4 @@
+
 =head1 NAME
 
 perlfunc - Perl builtin functions
@@ -79,117 +80,120 @@ than one place.
 
 =item Functions for SCALARs or strings
 
-chomp, chop, chr, crypt, hex, index, lc, lcfirst, length,
-oct, ord, pack, q/STRING/, qq/STRING/, reverse, rindex,
-sprintf, substr, tr///, uc, ucfirst, y///
+C<chomp>, C<chop>, C<chr>, C<crypt>, C<hex>, C<index>, C<lc>, C<lcfirst>,
+C<length>, C<oct>, C<ord>, C<pack>, C<q>/STRING/, C<qq>/STRING/, C<reverse>,
+C<rindex>, C<sprintf>, C<substr>, C<tr///>, C<uc>, C<ucfirst>, C<y>///
 
 =item Regular expressions and pattern matching
 
-m//, pos, quotemeta, s///, split, study
+C<m>//, C<pos>, C<quotemeta>, C<s>///, C<split>, C<study>
 
 =item Numeric functions
 
-abs, atan2, cos, exp, hex, int, log, oct, rand, sin, sqrt,
-srand
+C<abs>, C<atan2>, C<cos>, C<exp>, C<hex>, C<int>, C<log>, C<oct>, C<rand>,
+C<sin>, C<sqrt>, C<srand>
 
 =item Functions for real @ARRAYs
 
-pop, push, shift, splice, unshift
+C<pop>, C<push>, C<shift>, C<splice>, C<unshift>
 
 =item Functions for list data
 
-grep, join, map, qw/STRING/, reverse, sort, unpack
+C<grep>, C<join>, C<map>, C<qw>/STRING/, C<reverse>, C<sort>, C<unpack>
 
 =item Functions for real %HASHes
 
-delete, each, exists, keys, values
+C<delete>, C<each>, C<exists>, C<keys>, C<values>
 
 =item Input and output functions
 
-binmode, close, closedir, dbmclose, dbmopen, die, eof,
-fileno, flock, format, getc, print, printf, read, readdir,
-rewinddir, seek, seekdir, select, syscall, sysread, sysseek,
-syswrite, tell, telldir, truncate, warn, write
+C<binmode>, C<close>, C<closedir>, C<dbmclose>, C<dbmopen>, C<die>, C<eof>,
+C<fileno>, C<flock>, C<format>, C<getc>, C<print>, C<printf>, C<read>,
+C<readdir>, C<rewinddir>, C<seek>, C<seekdir>, C<select>, C<syscall>,
+C<sysread>, C<sysseek>, C<syswrite>, C<tell>, C<telldir>, C<truncate>,
+C<warn>, C<write>
 
 =item Functions for fixed length data or records
 
-pack, read, syscall, sysread, syswrite, unpack, vec
+C<pack>, C<read>, C<syscall>, C<sysread>, C<syswrite>, C<unpack>, C<vec>
 
 =item Functions for filehandles, files, or directories
 
-I<-X>, chdir, chmod, chown, chroot, fcntl, glob, ioctl, link,
-lstat, mkdir, open, opendir, readlink, rename, rmdir,
-stat, symlink, umask, unlink, utime
+C<-I<X>>, C<chdir>, C<chmod>, C<chown>, C<chroot>, C<fcntl>, C<glob>,
+C<ioctl>, C<link>, C<lstat>, C<mkdir>, C<open>, C<opendir>, C<readlink>,
+C<rename>, C<rmdir>, C<stat>, C<symlink>, C<umask>, C<unlink>, C<utime>
 
 =item Keywords related to the control flow of your perl program
 
-caller, continue, die, do, dump, eval, exit, goto, last,
-next, redo, return, sub, wantarray
+C<caller>, C<continue>, C<die>, C<do>, C<dump>, C<eval>, C<exit>,
+C<goto>, C<last>, C<next>, C<redo>, C<return>, C<sub>, C<wantarray>
 
 =item Keywords related to scoping
 
-caller, import, local, my, package, use
+C<caller>, C<import>, C<local>, C<my>, C<package>, C<use>
 
 =item Miscellaneous functions
 
-defined, dump, eval, formline, local, my, reset, scalar,
-undef, wantarray
+C<defined>, C<dump>, C<eval>, C<formline>, C<local>, C<my>, C<reset>,
+C<scalar>, C<undef>, C<wantarray>
 
 =item Functions for processes and process groups
 
-alarm, exec, fork, getpgrp, getppid, getpriority, kill,
-pipe, qx/STRING/, setpgrp, setpriority, sleep, system,
-times, wait, waitpid
+C<alarm>, C<exec>, C<fork>, C<getpgrp>, C<getppid>, C<getpriority>, C<kill>,
+C<pipe>, C<qx>/STRING/, C<setpgrp>, C<setpriority>, C<sleep>, C<system>,
+C<times>, C<wait>, C<waitpid>
 
 =item Keywords related to perl modules
 
-do, import, no, package, require, use
+C<do>, C<import>, C<no>, C<package>, C<require>, C<use>
 
 =item Keywords related to classes and object-orientedness
 
-bless, dbmclose, dbmopen, package, ref, tie, tied, untie, use
+C<bless>, C<dbmclose>, C<dbmopen>, C<package>, C<ref>, C<tie>, C<tied>,
+C<untie>, C<use>
 
 =item Low-level socket functions
 
-accept, bind, connect, getpeername, getsockname,
-getsockopt, listen, recv, send, setsockopt, shutdown,
-socket, socketpair
+C<accept>, C<bind>, C<connect>, C<getpeername>, C<getsockname>,
+C<getsockopt>, C<listen>, C<recv>, C<send>, C<setsockopt>, C<shutdown>,
+C<socket>, C<socketpair>
 
 =item System V interprocess communication functions
 
-msgctl, msgget, msgrcv, msgsnd, semctl, semget, semop,
-shmctl, shmget, shmread, shmwrite
+C<msgctl>, C<msgget>, C<msgrcv>, C<msgsnd>, C<semctl>, C<semget>, C<semop>,
+C<shmctl>, C<shmget>, C<shmread>, C<shmwrite>
 
 =item Fetching user and group info
 
-endgrent, endhostent, endnetent, endpwent, getgrent,
-getgrgid, getgrnam, getlogin, getpwent, getpwnam,
-getpwuid, setgrent, setpwent
+C<endgrent>, C<endhostent>, C<endnetent>, C<endpwent>, C<getgrent>,
+C<getgrgid>, C<getgrnam>, C<getlogin>, C<getpwent>, C<getpwnam>,
+C<getpwuid>, C<setgrent>, C<setpwent>
 
 =item Fetching network info
 
-endprotoent, endservent, gethostbyaddr, gethostbyname,
-gethostent, getnetbyaddr, getnetbyname, getnetent,
-getprotobyname, getprotobynumber, getprotoent,
-getservbyname, getservbyport, getservent, sethostent,
-setnetent, setprotoent, setservent
+C<endprotoent>, C<endservent>, C<gethostbyaddr>, C<gethostbyname>,
+C<gethostent>, C<getnetbyaddr>, C<getnetbyname>, C<getnetent>,
+C<getprotobyname>, C<getprotobynumber>, C<getprotoent>,
+C<getservbyname>, C<getservbyport>, C<getservent>, C<sethostent>,
+C<setnetent>, C<setprotoent>, C<setservent>
 
 =item Time-related functions
 
-gmtime, localtime, time, times
+C<gmtime>, C<localtime>, C<time>, C<times>
 
 =item Functions new in perl5
 
-abs, bless, chomp, chr, exists, formline, glob, import, lc,
-lcfirst, map, my, no, prototype, qx, qw, readline, readpipe,
-ref, sub*, sysopen, tie, tied, uc, ucfirst, untie, use
+C<abs>, C<bless>, C<chomp>, C<chr>, C<exists>, C<formline>, C<glob>,
+C<import>, C<lc>, C<lcfirst>, C<map>, C<my>, C<no>, C<prototype>, C<qx>,
+C<qw>, C<readline>, C<readpipe>, C<ref>, C<sub*>, C<sysopen>, C<tie>,
+C<tied>, C<uc>, C<ucfirst>, C<untie>, C<use>
 
 * - C<sub> was a keyword in perl4, but in perl5 it is an
 operator which can be used in expressions.
 
 =item Functions obsoleted in perl5
 
-dbmclose, dbmopen
+C<dbmclose>, C<dbmopen>
 
 =back
 
@@ -197,11 +201,11 @@ dbmclose, dbmopen
 
 =over 8
 
-=item -X FILEHANDLE
+=item I<-X> FILEHANDLE
 
-=item -X EXPR
+=item I<-X> EXPR
 
-=item -X
+=item I<-X>
 
 A file test, where X is one of the letters listed below.  This unary
 operator takes one argument, either a filename or a filehandle, and
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 75f4e6d..6a1ed81 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -432,10 +432,10 @@ status.
 
 If used in a numeric context, yields the current value of errno, with
 all the usual caveats.  (This means that you shouldn't depend on the
-value of "C<$!>" to be anything in particular unless you've gotten a
+value of C<$!> to be anything in particular unless you've gotten a
 specific error return indicating a system error.)  If used in a string
 context, yields the corresponding system error string.  You can assign
-to "C<$!>" to set I<errno> if, for instance, you want "C<$!>" to return the
+to C<$!> to set I<errno> if, for instance, you want C<"$!"> to return the
 string for error I<n>, or you want to set the exit value for the die()
 operator.  (Mnemonic: What just went bang?)
 
@@ -443,13 +443,31 @@ operator.  (Mnemonic: What just went bang?)
 
 =item $^E
 
-More specific information about the last system error than that provided by
-C<$!>, if available.  (If not, it's just C<$!> again.)
-At the moment, this differs from C<$!> under only VMS and OS/2, where it
-provides the VMS status value from the last system error, and OS/2 error
-code of the last call to OS/2 API either via CRT, or directly from perl.  The
-caveats mentioned in the description of C<$!> apply here, too.
-(Mnemonic: Extra error explanation.)
+Error information specific to the current operating system.  At
+the moment, this differs from C<$!> under only VMS, OS/2, and Win32
+(and for MacPerl).  On all other platforms, C<$^E> is always just
+the same as C<$!>.
+
+Under VMS, C<$^E> provides the VMS status value from the last
+system error.  This is more specific information about the last
+system error than that provided by C<$!>.  This is particularly
+important when C<$!> is set to E<EVMSERR>.
+
+Under OS/2, C<$^E> is set based on the value returned by the OS/2
+call C<_syserrno()> only when a call into the OS/2 API generates
+an error.  In this case, C<$!> is set to a special value to
+indicate that C<$^E> should be checked.  Otherwise, C<$^E> is
+just the same as C<$!>.
+
+Under Win32, C<$^E> always returns the last error information
+reported by the Win32 call C<GetLastError()> which describes
+the last error from within the Win32 API.  Most Win32-specific
+code will report errors via C<$^E>.  ANSI C and UNIX-like calls
+set C<errno> and so most portable Perl code will report errors
+via C<$!>. 
+
+Caveats mentioned in the description of C<$!> generally apply to
+C<$^E>, also.  (Mnemonic: Extra error explanation.)
 
 =item $EVAL_ERROR
 
diff --git a/util.c b/util.c
index 53ee31c..1c4b79a 100644
--- a/util.c
+++ b/util.c
@@ -2024,6 +2024,9 @@ my_pclose(FILE *ptr)
 #ifdef VMS
     int saved_vaxc_errno;
 #endif
+#ifdef WIN32
+    int saved_win32_errno;
+#endif
 
     svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
     pid = (int)SvIVX(*svp);
@@ -2039,6 +2042,9 @@ my_pclose(FILE *ptr)
 #ifdef VMS
 	saved_vaxc_errno = vaxc$errno;
 #endif
+#ifdef WIN32
+	saved_win32_errno = GetLastError();
+#endif
     }
 #ifdef UTS
     if(kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
diff --git a/win32/makedef.pl b/win32/makedef.pl
index 27bcf95..ddf01fd 100644
--- a/win32/makedef.pl
+++ b/win32/makedef.pl
@@ -508,6 +508,8 @@ win32_alarm
 win32_open_osfhandle
 win32_get_osfhandle
 win32_ioctl
+win32_wait
+win32_str_os_error
 Perl_win32_init
 Perl_init_os_extras
 Perl_getTHR
diff --git a/win32/win32.c b/win32/win32.c
index b965629..cd67fff 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -1068,6 +1068,33 @@ win32_strerror(int e)
     return strerror(e);
 }
 
+DllExport void
+win32_str_os_error(SV *sv, unsigned long dwErr)
+{
+    DWORD dwLen;
+    char *sMsg;
+    dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
+			  |FORMAT_MESSAGE_IGNORE_INSERTS
+			  |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
+			   dwErr, 0, (char *)&sMsg, 1, NULL);
+    if (0 < dwLen) {
+	while (0 < dwLen  &&  isspace(sMsg[--dwLen]))
+	    ;
+	if ('.' != sMsg[dwLen])
+	    dwLen++;
+	sMsg[dwLen]= '\0';
+    }
+    if (0 == dwLen) {
+	sMsg = LocalAlloc(0, 64/**sizeof(TCHAR)*/);
+	dwLen = sprintf(sMsg,
+			"Unknown error #0x%lX (lookup 0x%lX)",
+			dwErr, GetLastError());
+    }
+    sv_setpvn(sv, sMsg, dwLen);
+    LocalFree(sMsg);
+}
+
+
 DllExport int
 win32_fprintf(FILE *fp, const char *format, ...)
 {
diff --git a/win32/win32.h b/win32/win32.h
index 8075ee7..0edaad9 100644
--- a/win32/win32.h
+++ b/win32/win32.h
@@ -159,6 +159,7 @@ extern	char *	getlogin(void);
 
 DllExport void		Perl_win32_init(int *argcp, char ***argvp);
 DllExport void		Perl_init_os_extras(void);
+DllExport void		win32_str_os_error(struct sv *s, DWORD err);
 
 #ifndef USE_SOCKETS_AS_HANDLES
 extern FILE *		my_fdopen(int, char *);