diff options
39 files changed, 1477 insertions, 318 deletions
@@ -364,6 +364,9 @@ ext/SDBM_File/typemap SDBM extension interface types ext/Socket/Makefile.PL Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.xs Socket extension external subroutines +ext/Sys/Syslog/Makefile.PL Sys::Syslog extension makefile writer +ext/Sys/Syslog/Syslog.pm Sys::Syslog extension Perl module +ext/Sys/Syslog/Syslog.xs Sys::Syslog extension external subroutines ext/Thread/Makefile.PL Thread extension makefile writer ext/Thread/Notes Thread notes ext/Thread/README Thread README @@ -644,7 +647,6 @@ lib/SelfLoader.pm Load functions only on demand lib/Shell.pm Make AUTOLOADed system() calls lib/Symbol.pm Symbol table manipulation routines lib/Sys/Hostname.pm Hostname methods -lib/Sys/Syslog.pm Perl module supporting syslogging lib/Term/Cap.pm Perl module supporting termcap usage lib/Term/Complete.pm A command completion subroutine lib/Term/ReadLine.pm Stub readline library diff --git a/Makefile.SH b/Makefile.SH index fc1b606ba7..c3e5c851cd 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -30,7 +30,12 @@ case "$useshrplib" in true) # Prefix all runs of 'miniperl' and 'perl' with # $ldlibpth so that ./perl finds *this* shared libperl. - ldlibpth="LD_LIBRARY_PATH=`pwd`:$LD_LIBRARY_PATH" + case "$LD_LIBRARY_PATH" in + '') + ldlibpth="LD_LIBRARY_PATH=`pwd`";; + *) + ldlibpth="LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}";; + esac pldlflags="$cccdlflags" case "${osname}${osvers}" in @@ -78,6 +83,8 @@ true) eval "ldlibpth=\"$ldlibpthname=`pwd`:\$$ldlibpthname\"" ;; esac + # Strip off any trailing :'s + ldlibpth=`echo $ldlibpth | sed 's/:*$//'` ;; esac ;; @@ -287,7 +294,10 @@ FORCE: @sh -c true opmini$(OBJ_EXT): op.c - $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB -o opmini$(OBJ_EXT) op.c + $(RMS) opmini.c + $(LNS) op.c opmini.c + $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB opmini.c + $(RMS) opmini.c miniperlmain$(OBJ_EXT): miniperlmain.c $(CCCMD) $(PLDLFLAGS) $*.c diff --git a/configure.com b/configure.com index a77bec87cb..fade693862 100644 --- a/configure.com +++ b/configure.com @@ -1876,11 +1876,13 @@ $ echo "" $ echo "It's time to specify which modules you want to build into $ echo "perl. Most of these are standard and should be chosen, though $ echo "you might, for example, want to build GDBM_File instead of -$ echo "SDBM_File if you have the GDBM library built on your machine +$ echo "SDBM_File if you have the GDBM library built on your machine. +$ echo "Whatever you do, make sure the re module is first or things will +$ echo "break badly" $ echo " $ echo "Which modules do you want to build into perl?" $! dflt = "Fcntl Errno File::Glob IO Opcode Byteloader Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" -$ dflt = "Fcntl Errno File::Glob IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" +$ dflt = "re Fcntl Errno File::Glob IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File" $ if Using_Dec_C.eqs."Yes" $ THEN $ dflt = dflt + " POSIX" diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index d59c9dfe11..31e984f929 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -143,20 +143,21 @@ dprof_times(pTHX_ struct tms *t) #ifdef OS2 ULONG rc; QWORD cnt; + STRLEN n_a; if (!g_frequ) { if (CheckOSError(DosTmrQueryFreq(&g_frequ))) - croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na)); + croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a)); else g_frequ = g_frequ/DPROF_HZ; /* count per tick */ if (CheckOSError(DosTmrQueryTime(&cnt))) croak("DosTmrQueryTime: %s", - SvPV(perl_get_sv("!",TRUE),na)); + SvPV(perl_get_sv("!",TRUE), n_a)); g_start_cnt = toLongLong(cnt); } if (CheckOSError(DosTmrQueryTime(&cnt))) - croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na)); + croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a)); t->tms_stime = 0; return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ); #else /* !OS2 */ @@ -538,7 +539,7 @@ XS(XS_DB_sub) { HV *oldstash = PL_curstash; - DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na)); + DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); SAVEDESTRUCTOR_X(check_depth, (void*)g_depth); g_depth++; @@ -577,7 +578,7 @@ XS(XS_DB_goto) HV *oldstash = PL_curstash; SV *Sub = GvSV(PL_DBsub); /* name of current sub */ /* SP -= items; added by xsubpp */ - DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na)); + DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ diff --git a/ext/Devel/Peek/Peek.pm b/ext/Devel/Peek/Peek.pm index 38251c6ee8..080251bb5e 100644 --- a/ext/Devel/Peek/Peek.pm +++ b/ext/Devel/Peek/Peek.pm @@ -4,14 +4,14 @@ package Devel::Peek; # Underscore to allow older Perls to access older version from CPAN -$VERSION = '1.00_00'; +$VERSION = '1.00_01'; require Exporter; use XSLoader (); @ISA = qw(Exporter); @EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); -@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec); +@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV); %EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); XSLoader::load 'Devel::Peek'; diff --git a/ext/Devel/Peek/Peek.xs b/ext/Devel/Peek/Peek.xs index d2f66c40da..8af8847820 100644 --- a/ext/Devel/Peek/Peek.xs +++ b/ext/Devel/Peek/Peek.xs @@ -125,6 +125,10 @@ DeadCode(pTHX) PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str); #endif +#define _CvGV(cv) \ + (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ + ? (SV*)CvGV((CV*)SvRV(cv)) : &PL_sv_undef) + MODULE = Devel::Peek PACKAGE = Devel::Peek void @@ -206,3 +210,9 @@ CODE: RETVAL = DeadCode(aTHX); OUTPUT: RETVAL + +MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ + +SV * +_CvGV(cv) + SV *cv diff --git a/ext/Sys/Syslog/Makefile.PL b/ext/Sys/Syslog/Makefile.PL new file mode 100644 index 0000000000..253130a506 --- /dev/null +++ b/ext/Sys/Syslog/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Sys::Syslog', + VERSION_FROM => 'Syslog.pm', + XSPROTOARG => '-noprototypes', +); diff --git a/lib/Sys/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index f0cbb71924..b4473744c5 100644 --- a/lib/Sys/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -1,11 +1,13 @@ package Sys::Syslog; require 5.000; require Exporter; +require DynaLoader; use Carp; -@ISA = qw(Exporter); +@ISA = qw(Exporter DynaLoader); @EXPORT = qw(openlog closelog setlogmask syslog); @EXPORT_OK = qw(setlogsock); +$VERSION = '0.01'; use Socket; use Sys::Hostname; @@ -17,6 +19,7 @@ use Sys::Hostname; # NOTE: openlog now takes three arguments, just like openlog(3) # Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu> # with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list +# Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu> # Todo: enable connect to try all three types before failing (auto setlogsock)? @@ -98,10 +101,6 @@ Note that C<openlog> now takes three arguments, just like C<openlog(3)>. $! = 55; syslog('info', 'problem was %m'); # %m == $! in syslog(3) -=head1 DEPENDENCIES - -B<Sys::Syslog> needs F<syslog.ph>, which can be created with C<h2ph>. - =head1 SEE ALSO L<syslog(3)> @@ -111,10 +110,27 @@ L<syslog(3)> Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>. UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list. +Dependency on F<syslog.ph> replaced with XS code bu Tom Hughes E<lt>F<tom@compton.nu>E<gt>. =cut -require 'syslog.ph'; +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + croak "& not defined" if $constname eq 'constant'; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + croak "Your vendor has not defined Sys::Syslog macro $constname"; + } + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + +bootstrap Sys::Syslog $VERSION; $maskpri = &LOG_UPTO(&LOG_DEBUG); @@ -240,7 +256,7 @@ sub xlate { $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "Sys::Syslog::$name"; - defined &$name ? &$name : -1; + eval { &$name } || -1; } sub connect { diff --git a/ext/Sys/Syslog/Syslog.xs b/ext/Sys/Syslog/Syslog.xs new file mode 100644 index 0000000000..ac5220c24b --- /dev/null +++ b/ext/Sys/Syslog/Syslog.xs @@ -0,0 +1,635 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <sys/syslog.h> + +static double +constant_LOG_NO(char *name, int len, int arg) +{ + switch (name[6 + 0]) { + case 'T': + if (strEQ(name + 6, "TICE")) { /* LOG_NO removed */ +#ifdef LOG_NOTICE + return LOG_NOTICE; +#else + goto not_there; +#endif + } + case 'W': + if (strEQ(name + 6, "WAIT")) { /* LOG_NO removed */ +#ifdef LOG_NOWAIT + return LOG_NOWAIT; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_N(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'D': + if (strEQ(name + 5, "DELAY")) { /* LOG_N removed */ +#ifdef LOG_NDELAY + return LOG_NDELAY; +#else + goto not_there; +#endif + } + case 'E': + if (strEQ(name + 5, "EWS")) { /* LOG_N removed */ +#ifdef LOG_NEWS + return LOG_NEWS; +#else + goto not_there; +#endif + } + case 'F': + if (strEQ(name + 5, "FACILITIES")) { /* LOG_N removed */ +#ifdef LOG_NFACILITIES + return LOG_NFACILITIES; +#else + goto not_there; +#endif + } + case 'O': + return constant_LOG_NO(name, len, arg); + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_P(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'I': + if (strEQ(name + 5, "ID")) { /* LOG_P removed */ +#ifdef LOG_PID + return LOG_PID; +#else + goto not_there; +#endif + } + case 'R': + if (strEQ(name + 5, "RIMASK")) { /* LOG_P removed */ +#ifdef LOG_PRIMASK + return LOG_PRIMASK; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_AU(char *name, int len, int arg) +{ + if (6 + 2 >= len ) { + errno = EINVAL; + return 0; + } + switch (name[6 + 2]) { + case '\0': + if (strEQ(name + 6, "TH")) { /* LOG_AU removed */ +#ifdef LOG_AUTH + return LOG_AUTH; +#else + goto not_there; +#endif + } + case 'P': + if (strEQ(name + 6, "THPRIV")) { /* LOG_AU removed */ +#ifdef LOG_AUTHPRIV + return LOG_AUTHPRIV; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_A(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'L': + if (strEQ(name + 5, "LERT")) { /* LOG_A removed */ +#ifdef LOG_ALERT + return LOG_ALERT; +#else + goto not_there; +#endif + } + case 'U': + return constant_LOG_AU(name, len, arg); + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_CR(char *name, int len, int arg) +{ + switch (name[6 + 0]) { + case 'I': + if (strEQ(name + 6, "IT")) { /* LOG_CR removed */ +#ifdef LOG_CRIT + return LOG_CRIT; +#else + goto not_there; +#endif + } + case 'O': + if (strEQ(name + 6, "ON")) { /* LOG_CR removed */ +#ifdef LOG_CRON + return LOG_CRON; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_C(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'O': + if (strEQ(name + 5, "ONS")) { /* LOG_C removed */ +#ifdef LOG_CONS + return LOG_CONS; +#else + goto not_there; +#endif + } + case 'R': + return constant_LOG_CR(name, len, arg); + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_D(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'A': + if (strEQ(name + 5, "AEMON")) { /* LOG_D removed */ +#ifdef LOG_DAEMON + return LOG_DAEMON; +#else + goto not_there; +#endif + } + case 'E': + if (strEQ(name + 5, "EBUG")) { /* LOG_D removed */ +#ifdef LOG_DEBUG + return LOG_DEBUG; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_U(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'S': + if (strEQ(name + 5, "SER")) { /* LOG_U removed */ +#ifdef LOG_USER + return LOG_USER; +#else + goto not_there; +#endif + } + case 'U': + if (strEQ(name + 5, "UCP")) { /* LOG_U removed */ +#ifdef LOG_UUCP + return LOG_UUCP; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_E(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'M': + if (strEQ(name + 5, "MERG")) { /* LOG_E removed */ +#ifdef LOG_EMERG + return LOG_EMERG; +#else + goto not_there; +#endif + } + case 'R': + if (strEQ(name + 5, "RR")) { /* LOG_E removed */ +#ifdef LOG_ERR + return LOG_ERR; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_F(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'A': + if (strEQ(name + 5, "ACMASK")) { /* LOG_F removed */ +#ifdef LOG_FACMASK + return LOG_FACMASK; +#else + goto not_there; +#endif + } + case 'T': + if (strEQ(name + 5, "TP")) { /* LOG_F removed */ +#ifdef LOG_FTP + return LOG_FTP; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_LO(char *name, int len, int arg) +{ + if (6 + 3 >= len ) { + errno = EINVAL; + return 0; + } + switch (name[6 + 3]) { + case '0': + if (strEQ(name + 6, "CAL0")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL0 + return LOG_LOCAL0; +#else + goto not_there; +#endif + } + case '1': + if (strEQ(name + 6, "CAL1")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL1 + return LOG_LOCAL1; +#else + goto not_there; +#endif + } + case '2': + if (strEQ(name + 6, "CAL2")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL2 + return LOG_LOCAL2; +#else + goto not_there; +#endif + } + case '3': + if (strEQ(name + 6, "CAL3")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL3 + return LOG_LOCAL3; +#else + goto not_there; +#endif + } + case '4': + if (strEQ(name + 6, "CAL4")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL4 + return LOG_LOCAL4; +#else + goto not_there; +#endif + } + case '5': + if (strEQ(name + 6, "CAL5")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL5 + return LOG_LOCAL5; +#else + goto not_there; +#endif + } + case '6': + if (strEQ(name + 6, "CAL6")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL6 + return LOG_LOCAL6; +#else + goto not_there; +#endif + } + case '7': + if (strEQ(name + 6, "CAL7")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL7 + return LOG_LOCAL7; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_L(char *name, int len, int arg) +{ + switch (name[5 + 0]) { + case 'F': + if (strEQ(name + 5, "FMT")) { /* LOG_L removed */ +#ifdef LOG_LFMT + return LOG_LFMT; +#else + goto not_there; +#endif + } + case 'O': + return constant_LOG_LO(name, len, arg); + case 'P': + if (strEQ(name + 5, "PR")) { /* LOG_L removed */ +#ifdef LOG_LPR + return LOG_LPR; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant(char *name, int len, int arg) +{ + errno = 0; + if (0 + 4 >= len ) { + errno = EINVAL; + return 0; + } + switch (name[0 + 4]) { + case 'A': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_A(name, len, arg); + case 'C': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_C(name, len, arg); + case 'D': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_D(name, len, arg); + case 'E': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_E(name, len, arg); + case 'F': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_F(name, len, arg); + case 'I': + if (strEQ(name + 0, "LOG_INFO")) { /* removed */ +#ifdef LOG_INFO + return LOG_INFO; +#else + goto not_there; +#endif + } + case 'K': + if (strEQ(name + 0, "LOG_KERN")) { /* removed */ +#ifdef LOG_KERN + return LOG_KERN; +#else + goto not_there; +#endif + } + case 'L': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_L(name, len, arg); + case 'M': + if (strEQ(name + 0, "LOG_MAIL")) { /* removed */ +#ifdef LOG_MAIL + return LOG_MAIL; +#else + goto not_there; +#endif + } + case 'N': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_N(name, len, arg); + case 'O': + if (strEQ(name + 0, "LOG_ODELAY")) { /* removed */ +#ifdef LOG_ODELAY + return LOG_ODELAY; +#else + goto not_there; +#endif + } + case 'P': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_P(name, len, arg); + case 'S': + if (strEQ(name + 0, "LOG_SYSLOG")) { /* removed */ +#ifdef LOG_SYSLOG + return LOG_SYSLOG; +#else + goto not_there; +#endif + } + case 'U': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_U(name, len, arg); + case 'W': + if (strEQ(name + 0, "LOG_WARNING")) { /* removed */ +#ifdef LOG_WARNING + return LOG_WARNING; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + + +MODULE = Sys::Syslog PACKAGE = Sys::Syslog + +char * +_PATH_LOG() + CODE: +#ifdef _PATH_LOG + RETVAL = _PATH_LOG; +#else + croak("Your vendor has not defined the Sys::Syslog macro _PATH_LOG"); +#endif + OUTPUT: + RETVAL + +int +LOG_FAC(p) + INPUT: + int p + CODE: +#ifdef LOG_FAC + RETVAL = LOG_FAC(p); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_FAC"); +#endif + OUTPUT: + RETVAL + +int +LOG_PRI(p) + INPUT: + int p + CODE: +#ifdef LOG_PRI + RETVAL = LOG_PRI(p); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_PRI"); +#endif + OUTPUT: + RETVAL + +int +LOG_MAKEPRI(fac,pri) + INPUT: + int fac + int pri + CODE: +#ifdef LOG_MAKEPRI + RETVAL = LOG_MAKEPRI(fac,pri); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_MAKEPRI"); +#endif + OUTPUT: + RETVAL + +int +LOG_MASK(pri) + INPUT: + int pri + CODE: +#ifdef LOG_MASK + RETVAL = LOG_MASK(pri); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_MASK"); +#endif + OUTPUT: + RETVAL + +int +LOG_UPTO(pri) + INPUT: + int pri + CODE: +#ifdef LOG_UPTO + RETVAL = LOG_UPTO(pri); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_UPTO"); +#endif + OUTPUT: + RETVAL + + +double +constant(sv,arg) + PREINIT: + STRLEN len; + INPUT: + SV * sv + char * s = SvPV(sv, len); + int arg + CODE: + RETVAL = constant(s,len,arg); + OUTPUT: + RETVAL + diff --git a/hints/openbsd.sh b/hints/openbsd.sh index 4ae2611b07..7e68402088 100644 --- a/hints/openbsd.sh +++ b/hints/openbsd.sh @@ -5,14 +5,14 @@ # Andy Dougherty <doughera@lafcol.lafayette.edu> # # To build with distribution paths, use: -# ./Configure -des -Dopenbsd_distribution +# ./Configure -des -Dopenbsd_distribution=defined # # OpenBSD has a better malloc than perl... test "$usemymalloc" || usemymalloc='n' # Currently, vfork(2) is not a real win over fork(2) but this will -# change in a future release. +# change starting with OpenBSD 2.7. usevfork='true' # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions @@ -24,19 +24,20 @@ d_setrgid=$undef d_setruid=$undef # -# Not all platforms support shared libs... +# Not all platforms support dynamic loading... # -case `uname -m` in -alpha|mips|powerpc|vax) - d_dlopen=$undef +case `arch` in +OpenBSD.alpha|OpenBSD.mips|OpenBSD.powerpc|OpenBSD.vax) + usedl=$undef ;; *) + usedl=$define d_dlopen=$define d_dlerror=$define # we use -fPIC here because -fpic is *NOT* enough for some of the # extensions like Tk on some OpenBSD platforms (ie: sparc) cccdlflags="-DPIC -fPIC $cccdlflags" - lddlflags="-Bforcearchive -Bshareable $lddlflags" + lddlflags="-Bshareable $lddlflags" ;; esac @@ -74,17 +75,22 @@ EOCBU # When building in the OpenBSD tree we use different paths # This is only part of the story, the rest comes from config.over case "$openbsd_distribution" in -''|$undef|false|[nN]*) ;; +''|$undef|false) ;; *) # We put things in /usr, not /usr/local prefix='/usr' prefixexp='/usr' sysman='/usr/share/man/man1' - # Never look for things in /usr/local - glibpth='/usr/lib' libpth='/usr/lib' - locincpth='' - loclibpth='' + glibpth='/usr/lib' + # Ports installs non-std libs in /usr/local/lib so look there too + locincpth='/usr/local/include' + loclibpth='/usr/local/lib' + # Link perl with shared libperl + if [ "$usedl" = "$define" -a -r shlib_version ]; then + useshrplib=true + libperl=`. ./shlib_version; echo libperl.so.${major}.${minor}` + fi ;; esac diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 2f22b773c7..bbebf6fe81 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -6,13 +6,13 @@ use vars qw{$Try_autoload $Frontend $Defaultsite }; #}; -$VERSION = '1.50'; +$VERSION = '1.52'; -# $Id: CPAN.pm,v 1.264 1999/05/23 14:26:49 k Exp $ +# $Id: CPAN.pm,v 1.276 2000/01/08 15:29:46 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.264 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.276 $, 10)."]"; use Carp (); use Config (); @@ -61,7 +61,7 @@ use strict qw(vars); @CPAN::ISA = qw(CPAN::Debug Exporter); @EXPORT = qw( - autobundle bundle expand force get + autobundle bundle expand force get cvs_import install make readme recompile shell test clean ); @@ -90,7 +90,7 @@ sub AUTOLOAD { #-> sub CPAN::shell ; sub shell { my($self) = @_; - $Suppress_readline ||= ! -t STDIN; + $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; CPAN::Config->load unless $CPAN::Config_loaded++; my $prompt = "cpan> "; @@ -113,6 +113,12 @@ sub shell { $readline::rl_completion_function = $readline::rl_completion_function = 'CPAN::Complete::cpl'; } + # $term->OUT is autoflushed anyway + my $odef = select STDERR; + $| = 1; + select STDOUT; + $| = 1; + select $odef; } no strict; @@ -120,7 +126,8 @@ sub shell { my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my $cwd = CPAN->$getcwd(); - my $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub"; + my $try_detect_readline; + $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; my $rl_avail = $Suppress_readline ? "suppressed" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (try ``install Bundle::CPAN'')"; @@ -190,7 +197,8 @@ ReadLine support $rl_avail my $redef; local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef); require Term::ReadLine; - $CPAN::Frontend->myprint("\n$redef subroutines in Term::ReadLine redefined\n"); + $CPAN::Frontend->myprint("\n$redef subroutines in ". + "Term::ReadLine redefined\n"); goto &shell; } } @@ -575,7 +583,7 @@ Please make sure the directory exists and is writable. } my $fh; unless ($fh = FileHandle->new(">$lockfile")) { - if ($! =~ /Permission/ || $!{EACCES}) { + if ($! =~ /Permission/) { my $incc = $INC{'CPAN/Config.pm'}; my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); $CPAN::Frontend->myprint(qq{ @@ -613,6 +621,27 @@ or print "Caught SIGINT\n"; $Signal++; }; + +# From: Larry Wall <larry@wall.org> +# Subject: Re: deprecating SIGDIE +# To: perl5-porters@perl.org +# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT) +# +# The original intent of __DIE__ was only to allow you to substitute one +# kind of death for another on an application-wide basis without respect +# to whether you were in an eval or not. As a global backstop, it should +# not be used any more lightly (or any more heavily :-) than class +# UNIVERSAL. Any attempt to build a general exception model on it should +# be politely squashed. Any bug that causes every eval {} to have to be +# modified should be not so politely squashed. +# +# Those are my current opinions. It is also my optinion that polite +# arguments degenerate to personal arguments far too frequently, and that +# when they do, it's because both people wanted it to, or at least didn't +# sufficiently want it not to. +# +# Larry + $SIG{'__DIE__'} = \&cleanup; $self->debug("Signal handler set.") if $CPAN::DEBUG; } @@ -817,7 +846,7 @@ sub disk_usage { if ($^O eq 'MacOS') { require Mac::Files; my $cat = Mac::Files::FSpGetCatInfo($_); - $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen(); + $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat; } else { $Du += (-s _); } @@ -1136,7 +1165,8 @@ Known options: commit commit session changes to disk init go through a dialog to set all parameters -You may edit key values in the follow fashion: +You may edit key values in the follow fashion (the "o" is a literal +letter o): o conf build_cache 15 @@ -1182,29 +1212,29 @@ sub h { $CPAN::Frontend->myprint("Detailed help not yet implemented\n"); } else { $CPAN::Frontend->myprint(q{ -command arguments description -a string authors -b or display bundles -d /regex/ info distributions -m or about modules -i none anything of above - -r as reinstall recommendations -u above uninstalled distributions -See manpage for autobundle, recompile, force, look, etc. - -make make -test modules, make test (implies make) -install dists, bundles, make install (implies test) -clean "r" or "u" make clean -readme display the README file - -reload index|cpan load most recent indices/CPAN.pm -h or ? display this menu -o various set and query options -! perl-code eval a perl command -q quit the shell subroutine -}); +Display Information + a authors + b string display bundles + d or info distributions + m /regex/ about modules + i or anything of above + r none reinstall recommendations + u uninstalled distributions + +Download, Test, Make, Install... + get download + make make (implies get) + test modules, make test (implies make) + install dists, bundles make install (implies test) + clean make clean + look open subshell in these dists' directories + readme display these dists' README files + +Other + h,? display this menu ! perl-code eval a perl command + o conf [opt] set and query options q quit the cpan shell + reload cpan load CPAN.pm again reload index load newer indices + autobundle Snapshot force cmd unconditionally do cmd}); } } @@ -1326,10 +1356,13 @@ sub o { } } } else { - $CPAN::Frontend->myprint("Valid options for debug are ". - join(", ",sort(keys %CPAN::DEBUG), 'all'). - qq{ or a number. Completion works on the options. }. - qq{Case is ignored.\n\n}); + my $raw = "Valid options for debug are ". + join(", ",sort(keys %CPAN::DEBUG), 'all'). + qq{ or a number. Completion works on the options. }. + qq{Case is ignored.}; + require Text::Wrap; + $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); + $CPAN::Frontend->myprint("\n\n"); } if ($CPAN::DEBUG) { $CPAN::Frontend->myprint("Options set for debugging:\n"); @@ -1595,21 +1628,34 @@ sub expand { my $class = "CPAN::$type"; my $obj; if (defined $regex) { - for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class)) { - push @m, $obj - if - $obj->id =~ /$regex/i - or + for $obj ( + sort + {$a->id cmp $b->id} + $CPAN::META->all_objects($class) + ) { + unless ($obj->id){ + # BUG, we got an empty object somewhere + CPAN->debug(sprintf( + "Empty id on obj[%s]%%[%s]", + $obj, + join(":", %$obj) + )) if $CPAN::DEBUG; + next; + } + push @m, $obj + if $obj->id =~ /$regex/i + or ( ( - $] < 5.00303 ### provide sort of compatibility with 5.003 + $] < 5.00303 ### provide sort of + ### compatibility with 5.003 || $obj->can('name') ) && $obj->name =~ /$regex/i ); - } + } } else { my($xarg) = $arg; if ( $type eq 'Bundle' ) { @@ -1703,6 +1749,15 @@ sub mydie { die "\n"; } +sub setup_output { + return if -t STDOUT; + my $odef = select STDERR; + $| = 1; + select STDOUT; + $| = 1; + select $odef; +} + #-> sub CPAN::Shell::rematein ; # RE-adme||MA-ke||TE-st||IN-stall sub rematein { @@ -1713,6 +1768,7 @@ sub rematein { $pragma = $meth; $meth = shift @some; } + setup_output(); CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; my($s,@s); foreach $s (@some) { @@ -1789,6 +1845,8 @@ sub install { shift->rematein('install',@_); } sub clean { shift->rematein('clean',@_); } #-> sub CPAN::Shell::look ; sub look { shift->rematein('look',@_); } +#-> sub CPAN::Shell::cvs_import ; +sub cvs_import { shift->rematein('cvs_import',@_); } package CPAN::FTP; @@ -1965,6 +2023,9 @@ sub localize { my $ret = $self->$method(\@host_seq,$file,$aslocal); if ($ret) { $Themethod = $level; + my $now = time; + # utime $now, $now, $aslocal; # too bad, if we do that, we + # might alter a local mirror $self->debug("level[$level]") if $CPAN::DEBUG; return $ret; } else { @@ -2045,6 +2106,9 @@ sub hosteasy { my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { $Thesite = $i; + my $now = time; + utime $now, $now, $aslocal; # download time is more + # important than upload time return $aslocal; } elsif ($url !~ /\.gz$/) { my $gzurl = "$url.gz"; @@ -2119,8 +2183,8 @@ sub hosthard { HOSTHARD: for $i (@$host_seq) { my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; unless ($self->is_reachable($url)) { - $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); - next; + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; } $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; @@ -2130,90 +2194,107 @@ sub hosthard { # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { # to if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) { - # proto not yet used - ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); + # proto not yet used + ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); } else { - next HOSTHARD; # who said, we could ftp anything except ftp? + next HOSTHARD; # who said, we could ftp anything except ftp? } + $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; my($f,$funkyftp); for $f ('lynx','ncftpget','ncftp') { - next unless exists $CPAN::Config->{$f}; - $funkyftp = $CPAN::Config->{$f}; - next unless defined $funkyftp; - next if $funkyftp =~ /^\s*$/; - my($want_compressed); - my $aslocal_uncompressed; - ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; - my($source_switch) = ""; - $source_switch = " -source" if $funkyftp =~ /\blynx$/; - $source_switch = " -c" if $funkyftp =~ /\bncftp$/; - $CPAN::Frontend->myprint( - qq[ + next unless exists $CPAN::Config->{$f}; + $funkyftp = $CPAN::Config->{$f}; + next unless defined $funkyftp; + next if $funkyftp =~ /^\s*$/; + my($want_compressed); + my $aslocal_uncompressed; + ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; + my($source_switch) = ""; + if ($f eq "lynx"){ + $source_switch = " -source"; + } elsif ($f eq "ncftp"){ + $source_switch = " -c"; + } + my($chdir) = ""; + my($stdout_redir) = " > $aslocal_uncompressed"; + if ($f eq "ncftpget"){ + $chdir = "cd $aslocal_dir && "; + $stdout_redir = ""; + } + $CPAN::Frontend->myprint( + qq[ Trying with "$funkyftp$source_switch" to get $url ]); - my($system) = "$funkyftp$source_switch '$url' $devnull > ". - "$aslocal_uncompressed"; + my($system) = + "$chdir$funkyftp$source_switch '$url' $devnull$stdout_redir"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + ($f eq "lynx" ? + -s $aslocal_uncompressed # lynx returns 0 on my + # system even if it fails + : 1 + ) + ) { + if (-s $aslocal) { + # Looks good + } elsif ($aslocal_uncompressed ne $aslocal) { + # test gzip integrity + if ( + CPAN::Tarzip->gtest($aslocal_uncompressed) + ) { + rename $aslocal_uncompressed, $aslocal; + } else { + CPAN::Tarzip->gzip($aslocal_uncompressed, + "$aslocal_uncompressed.gz"); + } + } + $Thesite = $i; + return $aslocal; + } elsif ($url !~ /\.gz$/) { + unlink $aslocal_uncompressed if + -f $aslocal_uncompressed && -s _ == 0; + my $gz = "$aslocal.gz"; + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint( + qq[ +Trying with "$funkyftp$source_switch" to get + $url.gz +]); + my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". + "$aslocal_uncompressed.gz"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); if (($wstatus = system($system)) == 0 && - -s $aslocal_uncompressed # lynx returns 0 on my - # system even if it fails + -s "$aslocal_uncompressed.gz" ) { - if ($aslocal_uncompressed ne $aslocal) { - # test gzip integrity - if ( - CPAN::Tarzip->gtest($aslocal_uncompressed) - ) { - rename $aslocal_uncompressed, $aslocal; - } else { - CPAN::Tarzip->gzip($aslocal_uncompressed, - "$aslocal_uncompressed.gz"); - } - } - $Thesite = $i; - return $aslocal; - } elsif ($url !~ /\.gz$/) { - unlink $aslocal_uncompressed if - -f $aslocal_uncompressed && -s _ == 0; - my $gz = "$aslocal.gz"; - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint( - qq[ -Trying with "$funkyftp$source_switch" to get - $url.gz -]); - my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". - "$aslocal_uncompressed.gz"; - $self->debug("system[$system]") if $CPAN::DEBUG; - my($wstatus); - if (($wstatus = system($system)) == 0 - && - -s "$aslocal_uncompressed.gz" - ) { - # test gzip integrity - if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { - CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", - $aslocal); - } else { - rename $aslocal_uncompressed, $aslocal; - } - $Thesite = $i; - return $aslocal; + # test gzip integrity + if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { + CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", + $aslocal); } else { - unlink "$aslocal_uncompressed.gz" if - -f "$aslocal_uncompressed.gz"; + rename $aslocal_uncompressed, $aslocal; } + $Thesite = $i; + return $aslocal; } else { - my $estatus = $wstatus >> 8; - my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; - $CPAN::Frontend->myprint(qq{ + unlink "$aslocal_uncompressed.gz" if + -f "$aslocal_uncompressed.gz"; + } + } else { + my $estatus = $wstatus >> 8; + my $size = -f $aslocal ? + ", left\n$aslocal with size ".-s _ : + "\nWarning: expected file [$aslocal] doesn't exist"; + $CPAN::Frontend->myprint(qq{ System call "$system" returned status $estatus (wstat $wstatus)$size }); - } + } } } } @@ -2241,12 +2322,12 @@ sub hosthardest { next; } my($host,$dir,$getfile) = ($1,$2,$3); - my($netrcfile,$fh); my $timestamp = 0; my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, $ctime,$blksize,$blocks) = stat($aslocal); $timestamp = $mtime ||= 0; my($netrc) = CPAN::FTP::netrc->new; + my($netrcfile) = $netrc->netrc; my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; my $targetfile = File::Basename::basename($aslocal); my(@dialog); @@ -2259,7 +2340,7 @@ sub hosthardest { "get $getfile $targetfile", "quit" ); - if (! $netrc->netrc) { + if (! $netrcfile) { CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; } elsif ($netrc->hasdefault || $netrc->contains($host)) { CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", @@ -2496,10 +2577,10 @@ sub cpl { /^$word/, sort qw( ! a b d h i m o q r u autobundle clean - make test install force reload look + make test install force reload look cvs_import ) ); - } elsif ( $line !~ /^[\!abdhimorutl]/ ) { + } elsif ( $line !~ /^[\!abcdhimorutl]/ ) { @return = (); } elsif ($line =~ /^a\s/) { @return = cplx('CPAN::Author',$word); @@ -2507,7 +2588,7 @@ sub cpl { @return = cplx('CPAN::Bundle',$word); } elsif ($line =~ /^d\s/) { @return = cplx('CPAN::Distribution',$word); - } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) { + } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) { @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } elsif ($line =~ /^i\s/) { @return = cpl_any($word); @@ -2589,6 +2670,11 @@ sub reload { } return if $last_time + $CPAN::Config->{index_expire}*86400 > $time and ! $force; + ## IFF we are developing, it helps to wipe out the memory between + ## reloads, otherwise it is not what a user expects. + + ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274) + ## $CPAN::META = CPAN->new; my($debug,$t2); $last_time = $time; @@ -2708,7 +2794,7 @@ sub rd_modpacks { my($mod,$version,$dist) = split; ### $version =~ s/^\+//; - # if it is a bundle, instatiate a bundle object + # if it is a bundle, instantiate a bundle object my($bundle,$id,$userid); if ($mod eq 'CPAN' && @@ -2721,6 +2807,7 @@ sub rd_modpacks { if ($version > $CPAN::VERSION){ $CPAN::Frontend->myprint(qq{ There\'s a new CPAN.pm version (v$version) available! + [Current version is v$CPAN::VERSION] You might want to try install Bundle::CPAN reload cpan @@ -2764,12 +2851,20 @@ sub rd_modpacks { } # instantiate a distribution object - unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { - $CPAN::META->instance( - 'CPAN::Distribution' => $dist - )->set( - 'CPAN_USERID' => $userid - ); + if ($CPAN::META->exists('CPAN::Distribution',$dist)) { + # we do not need CONTAINSMODS unless we do something with + # this dist, so we better produce it on demand. + + ## my $obj = $CPAN::META->instance( + ## 'CPAN::Distribution' => $dist + ## ); + ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental + } else { + $CPAN::META->instance( + 'CPAN::Distribution' => $dist + )->set( + 'CPAN_USERID' => $userid + ); } return if $CPAN::Signal; @@ -2862,9 +2957,15 @@ sub as_string { $extra .= ")"; } if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX - push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + } elsif (ref($self->{$_}) eq "HASH") { + push @m, sprintf( + " %-12s %s%s\n", + $_, + join(" ",keys %{$self->{$_}}), + $extra); } else { - push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; + push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; } } join "", @m, "\n"; @@ -2909,6 +3010,25 @@ sub email { shift->{'EMAIL'} } package CPAN::Distribution; +#-> sub CPAN::Distribution::as_string ; +sub as_string { + my $self = shift; + $self->containsmods; + $self->SUPER::as_string(@_); +} + +#-> sub CPAN::Distribution::containsmods ; +sub containsmods { + my $self = shift; + return if exists $self->{CONTAINSMODS}; + for my $mod ($CPAN::META->all_objects("CPAN::Module")) { + my $mod_file = $mod->{CPAN_FILE} or next; + my $dist_id = $self->{ID} or next; + my $mod_id = $mod->{ID} or next; + $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; + } +} + #-> sub CPAN::Distribution::called_for ; sub called_for { my($self,$id) = @_; @@ -3114,6 +3234,44 @@ Please define it with "o conf shell <your shell>" chdir($pwd); } +sub cvs_import { + my($self) = @_; + $self->get; + my $dir = $self->dir; + + my $package = $self->called_for; + my $module = $CPAN::META->instance('CPAN::Module', $package); + my $version = $module->cpan_version; + + my $userid = $self->{CPAN_USERID}; + + my $cvs_dir = (split '/', $dir)[-1]; + $cvs_dir =~ s/-\d+[^-]+$//; + my $cvs_root = + $CPAN::Config->{cvsroot} || $ENV{CVSROOT}; + my $cvs_site_perl = + $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL}; + if ($cvs_site_perl) { + $cvs_dir = "$cvs_site_perl/$cvs_dir"; + } + my $cvs_log = qq{"imported $package $version sources"}; + $version =~ s/\./_/g; + my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, + "$cvs_dir", $userid, "v$version"); + + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $pwd = CPAN->$getcwd(); + chdir($dir); + + $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); + + $CPAN::Frontend->myprint(qq{@cmd\n}); + system(@cmd) == 0 or + $CPAN::Frontend->mydie("cvs import failed"); + chdir($pwd); +} + #-> sub CPAN::Distribution::readme ; sub readme { my($self) = @_; @@ -3325,8 +3483,7 @@ sub perl { $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { my ($component,$perl_name); - DIST_PERLNAME: - foreach $perl_name ($^X, 'perl', 'perl5', "perl$Config::Config{version}") { + DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { PATH_COMPONENT: foreach $component (MM->path(), $Config::Config{'binexp'}) { next unless defined($component) && $component; @@ -3706,13 +3863,14 @@ sub contains { my $fh = FileHandle->new; local $/ = "\n"; open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $inpod = 0; + my $in_cont = 0; $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; while (<$fh>) { - $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 : - m/^=head1\s+CONTENTS/ ? 1 : $inpod; - next unless $inpod; + $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 : + m/^=head1\s+CONTENTS/ ? 1 : $in_cont; + next unless $in_cont; next if /^=/; + s/\#.*//; next if /^\s+$/; chomp; push @result, (split " ", $_, 2)[0]; @@ -3758,7 +3916,7 @@ sub find_bundle_file { $what2 =~ s/:Bundle://; $what2 =~ tr|:|/|; } else { - $what2 =~ s|Bundle/||; + $what2 =~ s|Bundle[/\\]||; } my $bu; while (<$fh>) { @@ -3824,13 +3982,19 @@ explicitly a file $s. # recap with less noise if ( $meth eq "install") { if (%fail) { - $CPAN::Frontend->myprint(qq{\nBundle summary: }. - qq{The following items seem to }. - qq{have had installation problems:\n}); + require Text::Wrap; + my $raw = sprintf(qq{Bundle summary: +The following items in bundle %s had installation problems:}, + $self->id + ); + $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); + $CPAN::Frontend->myprint("\n"); + my $paragraph = ""; for $s ($self->contains) { - $CPAN::Frontend->myprint( "$s " ) if $fail{$s}; + $paragraph .= "$s " if $fail{$s}; } - $CPAN::Frontend->myprint(qq{\n}); + $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph)); + $CPAN::Frontend->myprint("\n"); } else { $self->{'install'} = 'YES'; } @@ -4060,6 +4224,8 @@ sub rematein { sub readme { shift->rematein('readme') } #-> sub CPAN::Module::look ; sub look { shift->rematein('look') } +#-> sub CPAN::Module::cvs_import ; +sub cvs_import { shift->rematein('cvs_import') } #-> sub CPAN::Module::get ; sub get { shift->rematein('get',@_); } #-> sub CPAN::Module::make ; @@ -4140,7 +4306,7 @@ sub inst_version { local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; # warn "HERE"; my $have = MM->parse_version($parsefile) || "undef"; - $have =~ s/\s+//g; + $have =~ s/\s*//g; # stringify to float around floating point issues $have; } @@ -4251,7 +4417,7 @@ sub DESTROY { $gz->gzclose(); } else { my $fh = $self->{FH}; - $fh->close; + $fh->close if defined $fh; } undef $self; } @@ -4262,29 +4428,30 @@ sub untar { if (MM->maybe_command($CPAN::Config->{'gzip'}) && MM->maybe_command($CPAN::Config->{'tar'})) { - if ($^O =~ /win/i) { # irgggh - # people find the most curious tar binaries that cannot handle - # pipes - my $system = "$CPAN::Config->{'gzip'} --decompress $file"; - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); - } else { - $CPAN::Frontend->mydie( - qq{Couldn\'t uncompress $file\n} - ); - } - $file =~ s/\.gz$//; - $system = "$CPAN::Config->{tar} xvf $file"; - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); - } else { - $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); - } - return 1; + my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . + "< $file | $CPAN::Config->{tar} xvf -"; + if (system($system) != 0) { + # people find the most curious tar binaries that cannot handle + # pipes + my $system = "$CPAN::Config->{'gzip'} --decompress $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); + } else { + $CPAN::Frontend->mydie( + qq{Couldn\'t uncompress $file\n} + ); + } + $file =~ s/\.gz$//; + $system = "$CPAN::Config->{tar} xvf $file"; + $CPAN::Frontend->myprint(qq{Using Tar:$system:\n}); + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); + } else { + $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); + } + return 1; } else { - my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . - "< $file | $CPAN::Config->{tar} xvf -"; - return system($system) == 0; + return 1; } } elsif ($CPAN::META->has_inst("Archive::Tar") && @@ -4340,8 +4507,8 @@ Modules are fetched from one or more of the mirrored CPAN directory. The CPAN module also supports the concept of named and versioned -'bundles' of modules. Bundles simplify the handling of sets of -related modules. See BUNDLES below. +I<bundles> of modules. Bundles simplify the handling of sets of +related modules. See Bundles below. The package contains a session manager and a cache manager. There is no status retained between sessions. The session manager keeps track @@ -4392,29 +4559,14 @@ objects. The parser recognizes a regular expression only if you enclose it between two slashes. The principle is that the number of found objects influences how an -item is displayed. If the search finds one item, the result is displayed -as object-E<gt>as_string, but if we find more than one, we display -each as object-E<gt>as_glimpse. E.g. - - cpan> a ANDK - Author id = ANDK - EMAIL a.koenig@franz.ww.TU-Berlin.DE - FULLNAME Andreas König - - - cpan> a /andk/ - Author id = ANDK - EMAIL a.koenig@franz.ww.TU-Berlin.DE - FULLNAME Andreas König - - - cpan> a /and.*rt/ - Author ANDYD (Andy Dougherty) - Author MERLYN (Randal L. Schwartz) +item is displayed. If the search finds one item, the result is +displayed with the rather verbose method C<as_string>, but if we find +more than one, we display each object with the terse method +<as_glimpse>. =item make, test, install, clean modules or distributions -These commands take any number of arguments and investigates what is +These commands take any number of arguments and investigate what is necessary to perform the action. If the argument is a distribution file name (recognized by embedded slashes), it is processed. If it is a module, CPAN determines the distribution file in which this module @@ -4456,12 +4608,11 @@ A C<clean> command results in a being executed within the distribution file's working directory. -=item readme, look module or distribution +=item get, readme, look module or distribution -These two commands take only one argument, be it a module or a -distribution file. C<readme> unconditionally runs, displaying the -README of the associated distribution file. C<Look> gets and -untars (if not yet done) the distribution file, changes to the +C<get> downloads a distribution file without further action. C<readme> +displays the README file of the associated distribution. C<Look> gets +and untars (if not yet done) the distribution file, changes to the appropriate directory and opens a subshell process in that directory. =item Signals @@ -4796,24 +4947,24 @@ shell with the command set defined within the C<o conf> command: =over 2 -=item o conf E<lt>scalar optionE<gt> +=item C<o conf E<lt>scalar optionE<gt>> prints the current value of the I<scalar option> -=item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt> +=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>> Sets the value of the I<scalar option> to I<value> -=item o conf E<lt>list optionE<gt> +=item C<o conf E<lt>list optionE<gt>> prints the current value of the I<list option> in MakeMaker's neatvalue format. -=item o conf E<lt>list optionE<gt> [shift|pop] +=item C<o conf E<lt>list optionE<gt> [shift|pop]> shifts or pops the array in the I<list option> variable -=item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt> +=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>> works like the corresponding perl commands. @@ -4916,10 +5067,10 @@ ftp) you will need to use LWP. =item ftp firewall -This where the firewall machine runs a ftp server. This kind of firewall will -only let you access ftp serves outside the firewall. This is usually done by -connecting to the firewall with ftp, then entering a username like -"user@outside.host.com" +This where the firewall machine runs a ftp server. This kind of +firewall will only let you access ftp servers outside the firewall. +This is usually done by connecting to the firewall with ftp, then +entering a username like "user@outside.host.com" To access servers outside these type of firewalls with perl you will need to use Net::FTP. @@ -4971,7 +5122,7 @@ traditional method of building a Perl module package from a shell. =head1 AUTHOR -Andreas König E<lt>a.koenig@kulturbox.deE<gt> +Andreas Koenig E<lt>andreas.koenig@anima.deE<gt> =head1 SEE ALSO diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 289984956c..0e795da4fb 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -16,7 +16,7 @@ use FileHandle (); use File::Basename (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.37 $, 10; +$VERSION = substr q$Revision: 1.38 $, 10; =head1 NAME @@ -360,17 +360,19 @@ sub conf_sites { require File::Copy; File::Copy::copy($m,$mby) or die "Could not update $mby: $!"; } + my $loopcount = 0; while () { if ( ! -f $mby ){ print qq{You have no $mby I\'m trying to fetch one }; $mby = CPAN::FTP->localize($m,$mby,3); - } elsif (-M $mby > 30 ) { - print qq{Your $mby is older than 30 days, + } elsif (-M $mby > 60 && $loopcount == 0) { + print qq{Your $mby is older than 60 days, I\'m trying to fetch one }; $mby = CPAN::FTP->localize($m,$mby,3); + $loopcount++; } elsif (-s $mby == 0) { print qq{You have an empty $mby, I\'m trying to fetch one diff --git a/lib/CPAN/Nox.pm b/lib/CPAN/Nox.pm index e9cb189f29..8b59ca07a1 100644 --- a/lib/CPAN/Nox.pm +++ b/lib/CPAN/Nox.pm @@ -1,7 +1,12 @@ package CPAN::Nox; +use strict; +use vars qw($VERSION @EXPORT); -BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;} +BEGIN{ + $CPAN::Suppress_readline=1 unless defined $CPAN::term; +} +use base 'Exporter'; use CPAN; $VERSION = "1.00"; @@ -12,6 +17,8 @@ $CPAN::META->has_inst('Compress::Zlib','no'); *AUTOLOAD = \&CPAN::AUTOLOAD; +__END__ + =head1 NAME CPAN::Nox - Wrapper around CPAN.pm without using any XS module diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm index 33f679363a..94b6aa6e78 100644 --- a/lib/Dumpvalue.pm +++ b/lib/Dumpvalue.pm @@ -347,16 +347,30 @@ sub dumpglob { } } +sub CvGV_name { + my $self = shift; + my $in = shift; + return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + sub dumpsub { my $self = shift; my ($off,$sub) = @_; + my $ini = $sub; + my $s; $sub = $1 if $sub =~ /^\{\*(.*)\}$/; - my $subref = \&$sub; - my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub}) - || ($self->{subdump} && ($sub = $self->findsubs("$subref")) - && $DB::sub{$sub}); + my $subref = defined $1 ? \&$sub : \&$ini; + my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s}) + || (($s = $self->CvGV_name($subref)) && $DB::sub{$s}) + || ($self->{subdump} && ($s = $self->findsubs("$subref")) + && $DB::sub{$s}); + $s = $sub unless defined $s; $place = '???' unless defined $place; - print( (' ' x $off) . "&$sub in $place\n" ); + print( (' ' x $off) . "&$s in $place\n" ); } sub findsubs { diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm index c9c67bd8e2..c727142506 100644 --- a/lib/Pod/Parser.pm +++ b/lib/Pod/Parser.pm @@ -142,8 +142,8 @@ For the most part, the B<Pod::Parser> base class should be able to do most of the input parsing for you and leave you free to worry about how to intepret the commands and translate the result. -Note that all we have described here in this quick overview overview is -the simplest most striaghtforward use of B<Pod::Parser> to do stream-based +Note that all we have described here in this quick overview is +the simplest most straightforward use of B<Pod::Parser> to do stream-based parsing. It is also possible to use the B<Pod::Parser::parse_text> function to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">. diff --git a/lib/byte.pm b/lib/byte.pm index 33ffb769e8..569fa660e0 100644 --- a/lib/byte.pm +++ b/lib/byte.pm @@ -1,11 +1,11 @@ package byte; sub import { - $^H |= 0x00000010; + $^H |= 0x00000008; } sub unimport { - $^H &= ~0x00000010; + $^H &= ~0x00000008; } sub AUTOLOAD { diff --git a/lib/charnames.pm b/lib/charnames.pm index 59350b2df9..817b4c559e 100644 --- a/lib/charnames.pm +++ b/lib/charnames.pm @@ -30,7 +30,7 @@ sub charnames { die "Unknown charname '$name'" unless @off; my $ord = hex substr $txt, $off[0] - 4, 4; - if ($^H & 0x10) { # "use byte" in effect? + if ($^H & 0x8) { # "use byte" in effect? use byte; return chr $ord if $ord <= 255; my $hex = sprintf '%X=0%o', $ord, $ord; diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index f473c45bd3..c72781801b 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -312,14 +312,27 @@ sub dumpglob { } } +sub CvGV_name_or_bust { + my $in = shift; + return if $skipCvGV; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + sub dumpsub { my ($off,$sub) = @_; + my $ini = $sub; + my $s; $sub = $1 if $sub =~ /^\{\*(.*)\}$/; - my $subref = \&$sub; - my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub}) - || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub}); + my $subref = defined $1 ? \&$sub : \&$ini; + my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s}) + || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s}) + || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s}); $place = '???' unless defined $place; - print( (' ' x $off) . "&$sub in $place\n" ); + $s = $sub unless defined $s; + print( (' ' x $off) . "&$s in $place\n" ); } sub findsubs { diff --git a/lib/perl5db.pl b/lib/perl5db.pl index aff5c687e7..de75bd7d86 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.04041; +$VERSION = 1.05; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -597,13 +597,21 @@ EOP } }; $cmd =~ s/^l\s+-\s*$/-/; - $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do { + $cmd =~ /^([lb])\b\s*(\$.*)/s && do { + $evalarg = $2; + my ($s) = &eval; + print($OUT "Error: $@\n"), next CMD if $@; + $s = CvGV_name($s); + print($OUT "Interpreted as: $1 $s\n"); + $cmd = "$1 $s"; + }; + $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do { $subname = $1; $subname =~ s/\'/::/; $subname = $package."::".$subname unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; - @pieces = split(/:/,find_sub($subname)); + @pieces = split(/:/,find_sub($subname) || $sub{$subname}); $subrange = pop @pieces; $file = join(':', @pieces); if ($file ne $filename) { @@ -784,7 +792,7 @@ EOP $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; next CMD; }; - $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { + $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do { $subname = $1; $cond = $2 || '1'; $subname =~ s/\'/::/; @@ -1813,6 +1821,7 @@ B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. B<l> I<min>B<->I<max> List lines I<min> through I<max>. B<l> I<line> List single I<line>. B<l> I<subname> List first window of lines from subroutine. +B<l> I<$var> List first window of lines from subroutine referenced by I<$var>. B<l> List next window of lines. B<-> List previous window of lines. B<w> [I<line>] List window around I<line>. @@ -1835,6 +1844,7 @@ B<b> [I<line>] [I<condition>] I<condition> breaks if it evaluates to true, defaults to '1'. B<b> I<subname> [I<condition>] Set breakpoint at first line of subroutine. +B<b> I<$var> Set breakpoint at first line of subroutine referenced by I<$var>. B<b> B<load> I<filename> Set breakpoint on `require'ing the given file. B<b> B<postpone> I<subname> [I<condition>] Set breakpoint at first line of subroutine after @@ -2063,10 +2073,31 @@ sub signalLevel { $signalLevel; } +sub CvGV_name { + my $in = shift; + my $name = CvGV_name_or_bust($in); + defined $name ? $name : $in; +} + +sub CvGV_name_or_bust { + my $in = shift; + return if $skipCvGV; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + sub find_sub { my $subr = shift; - return unless defined &$subr; $sub{$subr} or do { + return unless defined &$subr; + my $name = CvGV_name_or_bust($subr); + my $data; + $data = $sub{$name} if defined $name; + return $data if defined $data; + + # Old stupid way... $subr = \&$subr; # Hard reference my $s; for (keys %sub) { @@ -1748,9 +1748,9 @@ char * Perl_strdup(const char *s) { MEM_SIZE l = strlen(s); - char *s1 = (char *)Perl_malloc(l); + char *s1 = (char *)Perl_malloc(l+1); - Copy(s, s1, (MEM_SIZE)l, char); + Copy(s, s1, (MEM_SIZE)(l+1), char); return s1; } @@ -1776,8 +1776,8 @@ Perl_putenv(char *a) else var = Perl_malloc(l + 1); Copy(a, var, l, char); - val++; - my_setenv(var,val); + var[l + 1] = 0; + my_setenv(var, val+1); if (var != buf) Perl_mfree(var); return 0; @@ -4084,8 +4084,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) assert(!CvUNIQUE(proto)); ENTER; - SAVEVPTR(PL_curpad); - SAVESPTR(PL_comppad); + SAVECOMPPAD(); SAVESPTR(PL_comppad_name); SAVESPTR(PL_compcv); @@ -4306,14 +4305,26 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { dTHR; STRLEN n_a; - char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; - GV *gv = gv_fetchpv(name ? name : "__ANON__", - GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), - SVt_PVCV); + char *name; + char *aname; + GV *gv; char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; register CV *cv=0; I32 ix; + name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; + if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { + SV *sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]", + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + aname = SvPVX(sv); + } + else + aname = Nullch; + gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"), + GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), + SVt_PVCV); + if (o) SAVEFREEOP(o); if (proto) @@ -4365,7 +4376,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) && !(CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))) && strEQ(HvNAME(GvSTASH(CvGV(cv))), - "autouse"))) { + "autouse"))) + { line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ WARN_REDEFINE, @@ -4520,15 +4532,17 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } - if (name) { + if (name || aname) { char *s; + char *tname = (name ? name : aname); if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV *sv = NEWSV(0,0); SV *tmpstr = sv_newmortal(); GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); - CV *cv; + CV *pcv; HV *hv; + char *t; Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", CopFILE(PL_curcop), @@ -4537,19 +4551,20 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) - && (cv = GvCV(db_postponed))) { + && (pcv = GvCV(db_postponed))) + { dSP; PUSHMARK(SP); XPUSHs(tmpstr); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)pcv, G_DISCARD); } } - if ((s = strrchr(name,':'))) + if ((s = strrchr(tname,':'))) s++; else - s = name; + s = tname; if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') goto done; diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 005d7a92b6..3a50dc737c 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -41,7 +41,7 @@ CONFIG_ARGS = $config_args !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' -$(LIBPERL): perl.imp perl_dll perl5.def +$(LIBPERL): perl.imp $(PERL_DLL) perl5.def emximp -o $(LIBPERL) perl.imp $(AOUT_LIBPERL_DLL): perl.imp $(PERL_DLL) perl5.def @@ -96,9 +96,6 @@ perl.linkexp: perl.exports perl.map os2/os2.sym # We link miniperl statically, since .DLL depends on $(DYNALOADER) -opmini$(OBJ_EXT) : op.c - $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB -o opmini$(OBJ_EXT) op.c - miniperl.map miniperl: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) `echo $(obj)|sed -e 's/\bop\./opmini./g'` $(libs) -Zmap -Zlinker /map/PM:VIO @./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest @@ -2950,16 +2950,22 @@ typedef struct am_table_short AMTS; # endif #endif /* _FASTMATH */ -#define PERLDB_ALL 0x3f /* No _NONAME, _GOTO */ -#define PERLDBf_SUB 0x01 /* Debug sub enter/exit. */ -#define PERLDBf_LINE 0x02 /* Keep line #. */ -#define PERLDBf_NOOPT 0x04 /* Switch off optimizations. */ -#define PERLDBf_INTER 0x08 /* Preserve more data for - later inspections. */ -#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines. */ -#define PERLDBf_SINGLE 0x20 /* Start with single-step on. */ -#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr. */ -#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto. */ +#define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \ + PERLDBf_NOOPT | PERLDBf_INTER | \ + PERLDBf_SUBLINE| PERLDBf_SINGLE| \ + PERLDBf_NAMEEVAL| PERLDBf_NAMEANON) + /* No _NONAME, _GOTO */ +#define PERLDBf_SUB 0x01 /* Debug sub enter/exit */ +#define PERLDBf_LINE 0x02 /* Keep line # */ +#define PERLDBf_NOOPT 0x04 /* Switch off optimizations */ +#define PERLDBf_INTER 0x08 /* Preserve more data for + later inspections */ +#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines */ +#define PERLDBf_SINGLE 0x20 /* Start with single-step on */ +#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr */ +#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto */ +#define PERLDBf_NAMEEVAL 0x100 /* Informative names for evals */ +#define PERLDBf_NAMEANON 0x200 /* Informative names for anon subs */ #define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB)) #define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE)) @@ -2969,6 +2975,8 @@ typedef struct am_table_short AMTS; #define PERLDB_SINGLE (PL_perldb && (PL_perldb & PERLDBf_SINGLE)) #define PERLDB_SUB_NN (PL_perldb && (PL_perldb & (PERLDBf_NONAME))) #define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO)) +#define PERLDB_NAMEEVAL (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL)) +#define PERLDB_NAMEANON (PL_perldb && (PL_perldb & PERLDBf_NAMEANON)) #ifdef USE_LOCALE_NUMERIC diff --git a/pod/perldebug.pod b/pod/perldebug.pod index 65a07e21fa..1c94f5fda0 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -153,7 +153,8 @@ List a single line. =item l subname -List first window of lines from subroutine. +List first window of lines from subroutine. I<subname> may +be a variable which contains a code reference. =item - @@ -251,7 +252,9 @@ that begin an executable statement. Conditions don't use B<if>: =item b subname [condition] -Set a breakpoint at the first line of the named subroutine. +Set a breakpoint at the first line of the named subroutine. I<subname> may +be a variable which contains a code reference (in this case I<condition> +is not supported). =item b postpone subname [condition] diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 50721c3e52..a22f75ba4f 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1638,6 +1638,11 @@ A bug that may have caused data loss when more than one disk block happens to be read from the database in a single FETCH() has been fixed. +=item Sys::Syslog + +Sys::Syslog now uses XSUBs to access facilities from syslog.h so it +no longer requires syslog.ph to exist. + =item Time::Local The timelocal() and timegm() functions used to silently return bogus diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index 80b150d89c..3b0a79ffee 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -344,7 +344,7 @@ following list is I<not> the complete list of CPAN mirrors. Most of the major modules (Tk, CGI, libwww-perl) have their own mailing lists. Consult the documentation that came with the module for -subscription information. Perl Mongers attempts to maintain a +subscription information. The Perl Mongers attempt to maintain a list of mailing lists at: http://www.perl.org/support/online_support.html#mail diff --git a/pod/perlop.pod b/pod/perlop.pod index 68113b79c1..150813e711 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -789,7 +789,7 @@ the trailing delimiter. This avoids expensive run-time recompilations, and is useful when the value you are interpolating won't change over the life of the script. However, mentioning C</o> constitutes a promise that you won't change the variables in the pattern. If you change them, -Perl won't even notice. See also L<qr//>. +Perl won't even notice. See also L<"qr//">. If the PATTERN evaluates to the empty string, the last I<successfully> matched regular expression is used instead. diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 1f3ae50f2d..f07bdfeabf 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -5,21 +5,14 @@ perlsyn - Perl syntax =head1 DESCRIPTION A Perl script consists of a sequence of declarations and statements. -The only things that need to be declared in Perl are report formats -and subroutines. See the sections below for more information on those -declarations. All uninitialized user-created objects are assumed to -start with a C<null> or C<0> value until they are defined by some explicit -operation such as assignment. (Though you can get warnings about the -use of undefined values if you like.) The sequence of statements is -executed just once, unlike in B<sed> and B<awk> scripts, where the -sequence of statements is executed for each input line. While this means -that you must explicitly loop over the lines of your input file (or -files), it also means you have much more control over which files and -which lines you look at. (Actually, I'm lying--it is possible to do an -implicit loop with either the B<-n> or B<-p> switch. It's just not the -mandatory default like it is in B<sed> and B<awk>.) - -=head2 Declarations +The sequence of statements is executed just once, unlike in B<sed> +and B<awk> scripts, where the sequence of statements is executed +for each input line. While this means that you must explicitly +loop over the lines of your input file (or files), it also means +you have much more control over which files and which lines you look at. +(Actually, I'm lying--it is possible to do an implicit loop with +either the B<-n> or B<-p> switch. It's just not the mandatory +default like it is in B<sed> and B<awk>.) Perl is, for the most part, a free-form language. (The only exception to this is format declarations, for obvious reasons.) Text from a @@ -29,11 +22,27 @@ interpreted either as division or pattern matching, depending on the context, and C++ C<//> comments just look like a null regular expression, so don't do that. +=head2 Declarations + +The only things you need to declare in Perl are report formats +and subroutines--and even undefined subroutines can be handled +through AUTOLOAD. A variable holds the undefined value (C<undef>) +until it has been assigned a defined value, which is anything +other than C<undef>. When used as a number, C<undef> is treated +as C<0>; when used as a string, it is treated the empty string, +C<"">; and when used as a reference that isn't being assigned +to, it is treated as an error. If you enable warnings, you'll +be notified of an uninitialized value whenever you treat C<undef> +as a string or a number. Well, usually. Boolean ("don't-care") +contexts and operators such as C<++>, C<-->, C<+=>, C<-=>, and +C<.=> are always exempt from such warnings. + A declaration can be put anywhere a statement can, but has no effect on the execution of the primary sequence of statements--declarations all take effect at compile time. Typically all the declarations are put at the beginning or the end of the script. However, if you're using -lexically-scoped private variables created with C<my()>, you'll have to make sure +lexically-scoped private variables created with C<my()>, you'll +have to make sure your format or subroutine definition is within the same block scope as the my if you expect to be able to access those private variables. diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 3393fd930f..dca9cc092f 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -832,6 +832,23 @@ Keep info about source lines on which a subroutine is defined. Start with single-step on. +=item 0x40 + +Use subroutine address instead of name when reporting. + +=item 0x80 + +Report C<goto &subroutine> as well. + +=item 0x100 + +Provide informative "file" names for evals based on the place they were compiled. + +=item 0x200 + +Provide informative names to anonymous subroutines based on the place they +were compiled. + =back Some bits may be relevant at compile-time only, some at @@ -2570,7 +2570,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) I32 optype; OP dummy; OP *oop = PL_op, *rop; - char tmpbuf[TYPE_DIGITS(long) + 12 + 10]; + char tbuf[TYPE_DIGITS(long) + 12 + 10]; + char *tmpbuf = tbuf; char *safestr; ENTER; @@ -2584,7 +2585,15 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) } SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); - sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { + SV *sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", + code, (unsigned long)++PL_evalseq, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + tmpbuf = SvPVX(sv); + } + else + sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); CopFILE_set(&PL_compiling, tmpbuf+2); CopLINE_set(&PL_compiling, 1); /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up @@ -3155,7 +3164,8 @@ PP(pp_entereval) register PERL_CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = PL_sub_generation; - char tmpbuf[TYPE_DIGITS(long) + 12]; + char tbuf[TYPE_DIGITS(long) + 12]; + char *tmpbuf = tbuf; char *safestr; STRLEN len; OP *ret; @@ -3171,7 +3181,15 @@ PP(pp_entereval) /* switch to eval mode */ SAVECOPFILE(&PL_compiling); - sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { + SV *sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", + (unsigned long)++PL_evalseq, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + tmpbuf = SvPVX(sv); + } + else + sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); CopFILE_set(&PL_compiling, tmpbuf+2); CopLINE_set(&PL_compiling, 1); /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up @@ -934,6 +934,13 @@ Perl_leave_scope(pTHX_ I32 base) } *(I32*)&PL_hints = (I32)SSPOPINT; break; + case SAVEt_COMPPAD: + PL_comppad = (AV*)SSPOPPTR; + if (PL_comppad) + PL_curpad = AvARRAY(PL_comppad); + else + PL_curpad = Null(SV**); + break; default: Perl_croak(aTHX_ "panic: leave_scope inconsistency"); } @@ -31,6 +31,7 @@ #define SAVEt_DESTRUCTOR_X 30 #define SAVEt_VPTR 31 #define SAVEt_I8 32 +#define SAVEt_COMPPAD 33 #define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow() #define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i)) @@ -132,6 +133,19 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. } \ } STMT_END +#define SAVECOMPPAD() \ + STMT_START { \ + if (PL_comppad && PL_curpad == AvARRAY(PL_comppad)) { \ + SSCHECK(2); \ + SSPUSHPTR((SV*)PL_comppad); \ + SSPUSHINT(SAVEt_COMPPAD); \ + } \ + else { \ + SAVEVPTR(PL_curpad); \ + SAVESPTR(PL_comppad); \ + } \ + } STMT_END + #ifdef USE_ITHREADS # define SAVECOPSTASH(cop) SAVEPPTR(CopSTASHPV(cop)) # define SAVECOPFILE(cop) SAVEPPTR(CopFILE(cop)) @@ -6398,7 +6398,7 @@ void * Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) { PTR_TBL_ENT_t *tblent; - UV hash = (UV)sv; + UV hash = PTR2UV(sv); assert(tbl); tblent = tbl->tbl_ary[hash & tbl->tbl_max]; for (; tblent; tblent = tblent->next) { @@ -6415,7 +6415,7 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) /* XXX this may be pessimal on platforms where pointers aren't good * hash values e.g. if they grow faster in the most significant * bits */ - UV hash = (UV)oldv; + UV hash = PTR2UV(oldv); bool i = 1; assert(tbl); @@ -6455,7 +6455,7 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) continue; curentp = ary + oldsize; for (entp = ary, ent = *ary; ent; ent = *entp) { - if ((newsize & (UV)ent->oldval) != i) { + if ((newsize & PTR2UV(ent->oldval)) != i) { *entp = ent->next; ent->next = *curentp; *curentp = ent; diff --git a/t/op/closure.t b/t/op/closure.t index 52d2272b80..c691d6f034 100755 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -12,7 +12,7 @@ BEGIN { use Config; -print "1..170\n"; +print "1..171\n"; my $test = 1; sub test (&) { @@ -172,6 +172,15 @@ test { $foo[4]->()->(4) }; +{ + my $w; + $w = sub { + my ($i) = @_; + test { $i == 10 }; + sub { $w }; + }; + $w->(10); +} # Additional tests by Tom Phoenix <rootbeer@teleport.com>. diff --git a/t/op/fork.t b/t/op/fork.t index f3d74f978f..d82c04ff79 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -24,7 +24,7 @@ print "1..", scalar @prgs, "\n"; $tmpfile = "forktmp000"; 1 while -f ++$tmpfile; -END { unlink $tmpfile if $tmpfile; } +END { close TEST; unlink $tmpfile if $tmpfile; } $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); @@ -54,6 +54,8 @@ for (@prgs){ # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. $results =~ s/^(syntax|parse) error/syntax error/mig; + $results =~ s/^\n*Process terminated by SIG\w+\n?//mg + if $^O eq 'os2'; my @results = sort split /\n/, $results; if ( "@results" ne "@expected" ) { print STDERR "PROG: $switch\n$prog\n"; @@ -7039,8 +7039,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) SAVEI32(PL_subline); save_item(PL_subname); SAVEI32(PL_padix); - SAVEVPTR(PL_curpad); - SAVESPTR(PL_comppad); + SAVECOMPPAD(); SAVESPTR(PL_comppad_name); SAVESPTR(PL_compcv); SAVEI32(PL_comppad_name_fill); diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index ada0ff3d14..d8b49c7cea 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -230,7 +230,7 @@ NOOP = continue # are built using these macros should depend on $(MINIPERL_EXE) MINIPERL_EXE = Sys$Disk:[]miniperl$(E) MINIPERL = MCR $(MINIPERL_EXE) "-I[.lib]" -XSUBPP = $(MINIPERL) [.lib.extutils]xsubpp -noprototypes +XSUBPP = $(MINIPERL) "-I[.ext.re]" [.lib.extutils]xsubpp -noprototypes # Macro to invoke a preexisting copy of Perl. This is used to regenerate # some header files when rebuilding Perl, but premade versions are provided # in the distribution, so it's OK if this doesn't work; it's here to make @@ -806,6 +806,7 @@ test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t # install ought not need a source, but it doesn't work if one's not # there. Go figure... install : $(MINIPERL_EXE) + If F$TrnLnm("Sys") .nes. "" Then Deass SYS $(MINIPERL) installperl archify : all diff --git a/vms/subconfigure.com b/vms/subconfigure.com index 1e0d003826..b5d89bfaf1 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -63,6 +63,7 @@ $ myname = myhostname $ if "''myname'" .eqs. "" THEN myname = f$trnlnm("SYS$NODE") $! $! ##ADD NEW CONSTANTS HERE## +$ perl_d_nv_preserves_uv = "define" $ perl_d_fs_data_s = "undef" $ perl_d_getmnt = "undef" $ perl_d_sqrtl = "define" @@ -488,10 +489,13 @@ $ perl_arch = "''perl_arch'-thread" $ perl_archname = "''perl_archname'-thread" $ perl_d_old_pthread_create_joinable = "undef" $ perl_old_pthread_create_joinable = " " +$ perl_use5005threads = "define" $ ELSE $ perl_d_old_pthread_create_joinable = "undef" $ perl_old_pthread_create_joinable = " " +$ perl_use5005threads = "undef" $ ENDIF +$ perl_useithreads = "undef" $ perl_osvers=f$edit(osvers, "TRIM") $ if (perl_subversion + 0).eq.0 $ THEN @@ -1588,6 +1592,144 @@ $ ENDIF $ ENDIF $ WRITE_RESULT "d_strtoull is ''perl_d_strtoull'" $! +$! Check for strtouq +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <string.h> +$ WS "int main() +$ WS "{" +$ WS "unsigned __int64 result; +$ WS "result = strtouq(""123123"", NULL, 10); +$ WS "exit(0); +$ WS "}" +$ CS +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ on error then continue +$ on warning then continue +$ 'Checkcc' temp.c +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ if (teststatus.nes."1") +$ THEN +$ perl_d_strtouq="undef" +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ ELSE +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp.obj,temp.opt/opt +$ else +$ link temp.obj +$ endif +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_d_strtouq="undef" +$ ELSE +$ perl_d_strtouq="define" +$ ENDIF +$ ENDIF +$ WRITE_RESULT "d_strtouq is ''perl_d_strtouq'" +$! +$! Check for strtoll +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <string.h> +$ WS "int main() +$ WS "{" +$ WS "__int64 result; +$ WS "result = strtoll(""123123"", NULL, 10); +$ WS "exit(0); +$ WS "}" +$ CS +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ on error then continue +$ on warning then continue +$ 'Checkcc' temp.c +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ if (teststatus.nes."1") +$ THEN +$ perl_d_strtoll="undef" +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ ELSE +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp.obj,temp.opt/opt +$ else +$ link temp.obj +$ endif +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_d_strtoll="undef" +$ ELSE +$ perl_d_strtoll="define" +$ ENDIF +$ ENDIF +$ WRITE_RESULT "d_strtoll is ''perl_d_strtoll'" +$! +$! Check for strtold +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <string.h> +$ WS "int main() +$ WS "{" +$ WS "long double result; +$ WS "result = strtold(""123123"", NULL, 10); +$ WS "exit(0); +$ WS "}" +$ CS +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ on error then continue +$ on warning then continue +$ 'Checkcc' temp.c +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ if (teststatus.nes."1") +$ THEN +$ perl_d_strtold="undef" +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ ELSE +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp.obj,temp.opt/opt +$ else +$ link temp.obj +$ endif +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_d_strtold="undef" +$ ELSE +$ perl_d_strtold="define" +$ ENDIF +$ ENDIF +$ WRITE_RESULT "d_strtold is ''perl_d_strtold'" +$! $! Check for atoll $! $ OS @@ -2941,8 +3083,8 @@ $ perl_i16type="short" $ perl_u16type="unsigned short" $ perl_i32type="int" $ perl_u32type="unsigned int" -$ perl_i64type="long" -$ perl_u64type="unsigned long" +$ perl_i64type="long long" +$ perl_u64type="unsigned long long" $ perl_nvtype="double" $! $ GOTO beyond_type_size_check @@ -3117,6 +3259,9 @@ $ WC "# Time: " + perl_cf_time $ WC "" $ WC "CONFIGDOTSH=true" $ WC "package='" + perl_package + "'" +$ WC "d_nv_preserves_uv='" + perl_d_nv_preserves_uv + "'" +$ WC "use5005threads='" + perl_use5005threads + "'" +$ WC "useithreads='" + perl_useithreads + "'" $ WC "CONFIG='" + perl_config + "'" $ WC "cf_time='" + perl_cf_time + "'" $ WC "cf_by='" + perl_cf_by+ "'" @@ -3574,6 +3719,9 @@ $ WC "crosscompile='" + perl_crosscompile + "'" $ WC "multiarch='" + perl_multiarch + "'" $ WC "sched_yield='" + perl_sched_yield + "'" $ WC "d_strtoull='" + perl_d_strtoull + "'" +$ WC "d_strtouq='" + perl_d_strtouq + "'" +$ WC "d_strtoll='" + perl_d_strtoll + "'" +$ WC "d_strtold='" + perl_d_strtold + "'" $ WC "usesocks='" + perl_usesocks + "'" $ WC "d_vendorlib='" + perl_d_vendorlib + "'" $ WC "vendorlibexp='" + perl_vendorlibexp + "'" @@ -23,7 +23,7 @@ void XS_attributes_bootstrap(pTHXo_ CV *cv); * * The various bootstrap definitions can take care of doing * package-specific newXS() calls. Since the layout of the - * bundled lib/*.pm files is in a version-specific directory, + * bundled *.pm files is in a version-specific directory, * version checks in these bootstrap calls are optional. */ |