diff options
| -rw-r--r-- | doio.c | 3 | ||||
| -rw-r--r-- | lib/dumpvar.pl | 3 | ||||
| -rw-r--r-- | lib/perl5db.pl | 12 | ||||
| -rw-r--r-- | mg.c | 17 | ||||
| -rw-r--r-- | perl.h | 6 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 100 | ||||
| -rw-r--r-- | pod/perlvar.pod | 36 | ||||
| -rw-r--r-- | util.c | 6 | ||||
| -rw-r--r-- | win32/makedef.pl | 2 | ||||
| -rw-r--r-- | win32/win32.c | 27 | ||||
| -rw-r--r-- | win32/win32.h | 1 |
11 files changed, 146 insertions, 67 deletions
@@ -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 c32bc2fb5e..cc7da89a62 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 ea072e0f3b..f0774bcdac 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. @@ -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); @@ -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 49d455b6a2..a89ee99e06 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 75f4e6d5c2..6a1ed81c5d 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 @@ -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 27bcf95295..ddf01fdab8 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 b965629383..cd67fff2bf 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 8075ee7389..0edaad9d52 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 *); |