From e7ea3e70155d0bea30720ba41eb6bb6742aac0d1 Mon Sep 17 00:00:00 2001 From: Ilya Zakharevich Date: Tue, 21 Jan 1997 10:26:32 +1200 Subject: patch for LWP 5.05 to make it play with both 5.003 and 5.003_20 + overload patch --- gv.c | 18 +-- lib/diagnostics.pm | 5 +- lib/overload.pm | 89 +++++++++++--- pod/perldebug.pod | 354 +++++++++++++++++++++++++++++++++++++++++++++-------- pod/perldiag.pod | 40 +++--- pod/perlfunc.pod | 13 +- pod/perlop.pod | 26 ++++ pod/perlre.pod | 6 +- pod/perlxs.pod | 26 +++- 9 files changed, 476 insertions(+), 101 deletions(-) diff --git a/gv.c b/gv.c index 89533ff906..3b09463e16 100644 --- a/gv.c +++ b/gv.c @@ -912,8 +912,8 @@ HV* stash; AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL; AMT amt; - if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation && - amtp->was_ok_sub == sub_generation) + if (mg && amtp->was_ok_am == amagic_generation + && amtp->was_ok_sub == sub_generation) return AMT_AMAGIC(amtp); if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; @@ -997,10 +997,10 @@ HV* stash; if ( cp = (char *)AMG_names[0] ) { /* Try to find via inheritance. */ - gv = gv_fetchmeth(stash, "()", 2, 0); /* A cooky: "()". */ + gv = gv_fetchmeth(stash, "()", 2, -1); /* A cooky: "()". */ if (gv) sv = GvSV(gv); - if (!sv) /* Empty */; + if (!gv) goto notable; else if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; } @@ -1057,6 +1057,7 @@ HV* stash; } } /* Here we have no table: */ + notable: AMT_AMAGIC_off(&amt); sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); return FALSE; @@ -1222,8 +1223,9 @@ int flags; notfound = 1; lr = 1; } else { if (off==-1) off=method; - sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s", + sprintf(buf, "Operation `%s': no method found,%sargument %s%.256s%s%.256s", AMG_names[method + assignshift], + (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", @@ -1231,8 +1233,10 @@ int flags; HvNAME(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? - "in overloaded package ": - "has no overloaded magic", + ",\n\tright argument in overloaded package ": + (flags & AMGf_unary + ? "" + : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? HvNAME(SvSTASH(SvRV(right))): ""); diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index b00349f7b0..05d11780ad 100644 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -326,8 +326,9 @@ EOFUNC #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; $lhs =~ s/\377([^\377]*)$/\Q$1\E/; $lhs =~ s/\377//g; + $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all } - $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; + $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; } else { $transmo .= " m{^\Q$header\E} && return 1;\n"; } @@ -506,7 +507,7 @@ sub unescape { sub shorten { my $line = $_[0]; - if (length $line > 79) { + if (length $line > 79 and index $line, "\n" == -1) { my $space_place = rindex($line, ' ', 79); if ($space_place != -1) { substr($line, $space_place, 1) = "\n\t"; diff --git a/lib/overload.pm b/lib/overload.pm index 049545995c..2bbb639d9b 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -149,9 +149,10 @@ the "class" C (or one of its base classes) for the assignment form C<*=> of multiplication. Arguments of this directive come in (key, value) pairs. Legal values -are values legal inside a C<&{ ... }> call, so the name of a subroutine, -a reference to a subroutine, or an anonymous subroutine will all work. -Legal keys are listed below. +are values legal inside a C<&{ ... }> call, so the name of a +subroutine, a reference to a subroutine, or an anonymous subroutine +will all work. Note that values specified as strings are +interpreted as methods, not subroutines. Legal keys are listed below. The subroutine C will be called to execute C<$a+$b> if $a is a reference to an object blessed into the package C, or if $a is @@ -161,6 +162,10 @@ C<$a+=7>, or C<$a++>. See L. (Mathemagical methods refer to methods triggered by an overloaded mathematical operator.) +Since overloading respects @ISA hierarchy, in fact the above +declaration would also trigger overloading of C<+> and C<*=> in all +the packages which inherit from C. + =head2 Calling Conventions for Binary Operations The functions specified in the C directive are called @@ -269,6 +274,40 @@ see L>. See L<"Fallback"> for an explanation of when a missing method can be autogenerated. +=head2 Inheritance and overloading + +There are two ways how inheritance interacts with overloading. + +=over + +=item Strings as values of C directive + +If the value of + + use overload key => value; + +directive is a string, it is interpreted as a method name. + +=item Overloading of an operation is inherited by derived classes + +If any of ancestors is overloaded, so is the derived class. The set of +overloaded methods is the union of overloaded methods of all the +ancestors. If some method is overloaded in several ancestor, then +which description will be used is decided by the usual inheritance +rules: + +If C inherits from C and C (in this order), and C +overloads C<+> by C<\&D::plus_sub>, C overloads C<+> by +C<"plus_meth">, then the subroutine C will be called to +implement operation C<+> for an object in package C. + +=back + +Note that since the value of C key is not a subroutine, its +inheritance is not governed by the above rules. Current implementation +is that the value of C in the first overloaded ancestor is +taken, but this may be subject to change. + =head1 SPECIAL SYMBOLS FOR C Three keys are recognized by Perl that are not covered by the above @@ -321,6 +360,9 @@ C<"nomethod"> value, and if this is missing, raises an exception. =back +B C<"fallback"> inheritance via @ISA is not carved in stone +yet, see L<"Inheritance and overloading">. + =head2 Copy Constructor The value for C<"="> is a reference to a function with three @@ -484,16 +526,21 @@ Returns C or a reference to the method that implements C. What follows is subject to change RSN. -The table of methods for all operations is cached as magic in the -symbol table hash for the package. The table is rechecked for changes due to -C, C, and @ISA only during -Cing; so if they are changed dynamically, you'll need an -additional fake Cing to update the table. - -(Every SVish thing has a magic queue, and magic is an entry in that queue. -This is how a single variable may participate in multiple forms of magic -simultaneously. For instance, environment variables regularly have two -forms at once: their %ENV magic and their taint magic.) +The table of methods for all operations is cached in magic for the +symbol table hash for the package. The cache is invalidated during +processing of C, C, new function +definitions, and changes in @ISA. However, this invalidation remains +unprocessed until the next Cing into the package. Hence if you +want to change overloading structure dynamically, you'll need an +additional (fake) Cing to update the table. + +(Every SVish thing has a magic queue, and magic is an entry in that +queue. This is how a single variable may participate in multiple +forms of magic simultaneously. For instance, environment variables +regularly have two forms at once: their %ENV magic and their taint +magic. However, the magic which implements overloading is applied to +the stashes, which are rarely used directly, thus should not slow down +Perl.) If an object belongs to a package using overload, it carries a special flag. Thus the only speed penalty during arithmetic operations without @@ -502,13 +549,17 @@ overloading is the checking of this flag. In fact, if C is not present, there is almost no overhead for overloadable operations, so most programs should not suffer measurable performance penalties. A considerable effort was made to minimize the overhead -when overload is used and the current operation is overloadable but +when overload is used in some package, but the arguments in question do not belong to packages using overload. When in doubt, test your speed with C and without it. So far there have been no reports of substantial speed degradation if Perl is compiled with optimization turned on. -There is no size penalty for data if overload is not used. +There is no size penalty for data if overload is not used. The only +size penalty if overload is used in some package is that I the +packages acquire a magic during the next Cing into the +package. This magic is three-words-long for packages without +overloading, and carries the cache tabel if the package is overloaded. Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is carried out before any operation that can imply an assignment to the @@ -527,6 +578,14 @@ Ilya Zakharevich EFE. When Perl is run with the B<-Do> switch or its equivalent, overloading induces diagnostic messages. +Using the C command of Perl debugger (see L) one can +deduce which operations are overloaded (and which ancestor triggers +this overloading). Say, if C is overloaded, then the method C<(eq> +is shown by debugger. The method C<()> corresponds to the C +key (in fact a presence of this method shows that this package has +overloading enabled, and it is what is used by the C +function). + =head1 BUGS Because it is used for overloading, the per-package associative array diff --git a/pod/perldebug.pod b/pod/perldebug.pod index 77502f27d3..8e595f54e4 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -60,12 +60,17 @@ it's run through your pager, as in DB> |h +You may change the pager which is used via C command. + =item p expr Same as C in the current package. In particular, because this is just Perl's own B function, this means that nested data structures and objects are not dumped, unlike with the C command. +The C filehandle is opened to F, regardless of +where STDOUT may be redirected to. + =item x expr Evaluates its expression in list context and dumps out the result @@ -105,10 +110,12 @@ Single step. Executes until it reaches the beginning of another statement, descending into subroutine calls. If an expression is supplied that includes function calls, it too will be single-stepped. -=item n +=item n [expr] Next. Executes over subroutine calls, until it reaches the beginning -of the next statement. +of the next statement. If an expression is +supplied that includes function calls, it too will be executed with +stops before each statement. =item ECRE @@ -129,7 +136,7 @@ List C lines starting at C. =item l min-max -List lines C through C. +List lines C through C. C is synonymous to C<->. =item l line @@ -154,7 +161,9 @@ print it out. =item f filename -Switch to viewing a different file. +Switch to viewing a different file or eval statement. If C +is not a full filename as found in values of %INC, it is considered as +a regexp. =item /pattern/ @@ -235,7 +244,13 @@ Set breakpoint at first line of subroutine after it is compiled. =item b load filename -Set breakpoint at the first executed line of the file. +Set breakpoint at the first executed line of the file. Filename should +be a full name as found in values of %INC. + +=item b compile subname + +Sets breakpoint at the first statement executed after the subroutine +is compiled. =item d [line] @@ -273,34 +288,41 @@ be abbreviated. Several options can be listed. =over 12 -=item recallCommand, ShellBang +=item C, C The characters used to recall command or spawn shell. By default, these are both set to C. -=item pager +=item C Program to use for output of pager-piped commands (those beginning with a C<|> character.) By default, C<$ENV{PAGER}> will be used. -=item tkRunning +=item C Run Tk while prompting (with ReadLine). -=item signalLevel, warnLevel, dieLevel +=item C, C, C + +Level of verbosity. By default the debugger is in a sane verbose mode, +thus it will print backtraces on all the warnings and die-messages +which are going to be printed out, and will print a message when +interesting uncaught signals arrive. -Level of verbosity. +To disable this behaviour, set these values to 0. If C is 2, +then the messages which will be caught by surrounding C are also +printed. -=item AutoTrace +=item C -Where to print all the breakable points in the executed program -(similar to C command, but can be put into C). +Trace mode (similar to C command, but can be put into +C). -=item LineInfo +=item C -File or pipe to print line number info to. If it is a -pipe, then a short, "emacs like" message is used. +File or pipe to print line number info to. If it is a pipe (say, +C<|visual_perl_db>), then a short, "emacs like" message is used. =item C @@ -317,7 +339,14 @@ C is false, messages are printed on entry only. (Printing on exit may be useful if inter(di)spersed with other messages.) If C, arguments to functions are printed as well as the -context and caller info. +context and caller info. If C, overloaded C and +Cd C are enabled on the printed arguments. The length at +which the argument list is truncated is governed by the next option: + +=item C + +length at which the argument list is truncated when C option's +bit 4 is set. =back @@ -326,29 +355,38 @@ commands: =over 12 -=item arrayDepth, hashDepth +=item C, C Print only first N elements ('' for all). -=item compactDump, veryCompact +=item C, C -Change style of array and hash dump. +Change style of array and hash dump. If C, short array +may be printed on one line. -=item globPrint +=item C Whether to print contents of globs. -=item DumpDBFiles +=item C Dump arrays holding debugged files. -=item DumpPackages +=item C Dump symbol tables of packages. -=item quote, HighBit, undefPrint +=item C, C, C + +Change style of string dump. Default value of C is C, one +can enable either double-quotish dump, or single-quotish by setting it +to C<"> or C<'>. By default, characters with high bit set are printed +I. + +=item C -Change style of string dump. +I rudimentally per-package memory usage dump. Calculates total +size of strings in variables in the package. =back @@ -358,7 +396,7 @@ C, and C there. Example rc file: - &parse_options("NonStop=1 LineInfo=db.out AutoTrace"); + &parse_options("NonStop=1 LineInfo=db.out AutoTrace"); The script will run without human intervention, putting trace information into the file I. (If you interrupt it, you would better reset @@ -370,13 +408,6 @@ C to something "interactive"!) The TTY to use for debugging I/O. -=item noTTY - -If set, goes in C mode. On interrupt if TTY is not set uses the -value of C or "/tmp/perldbtty$$" to find TTY using -C. Current variant is to have the name of TTY in this -file. - =item C If set, goes in C mode, and would not connect to a TTY. If @@ -405,7 +436,7 @@ programmatically by setting $DB::signal or $DB::single. Here's an example of using the C<$ENV{PERLDB_OPTS}> variable: - $ PERLDB_OPTS="N f=2" perl -d myprogram + $ PERLDB_OPTS="N f=2" perl -d myprogram will run the script C without human intervention, printing out the call tree with entry and exit points. Note that C is @@ -416,7 +447,7 @@ C options). Other examples may include - $ PERLDB_OPTS="N f A L=listing" perl -d myprogram + $ PERLDB_OPTS="N f A L=listing" perl -d myprogram - runs script non-interactively, printing info on each entry into a subroutine and each executed line into the file F. (If you @@ -424,13 +455,13 @@ interrupt it, you would better reset C to something "interactive"!) - $ env "PERLDB_OPTS=R=0 TTY=/dev/ttyc" perl -d myprogram + $ env "PERLDB_OPTS=R=0 TTY=/dev/ttyc" perl -d myprogram may be useful for debugging a program which uses C itself. Do not forget detach shell from the TTY in the window which corresponds to F, say, by issuing a command like - $ sleep 1000000 + $ sleep 1000000 See L<"Debugger Internals"> below for more details. @@ -527,20 +558,34 @@ output, such as =item = [alias value] -Define a command alias, or list current aliases. +Define a command alias, like + + = quit q + +or list current aliases. =item command Execute command as a Perl statement. A missing semicolon will be supplied. -=item p expr +=item m expr -Same as C. The DB::OUT filehandle is opened to -/dev/tty, regardless of where STDOUT may be redirected to. +The expression is evaluated, and the methods which may be applied to +the result are listed. + +=item m package + +The methods which may be applied to objects in the C are listed. =back +=head2 Debugger input/output + +=over 8 + +=item Prompt + The debugger prompt is something like DB<8> @@ -557,9 +602,12 @@ you'd already at a breakpoint and then printed out the result of a function call that itself also has a breakpoint, or you step into an expression via C command. +=item Multi-line commands + If you want to enter a multi-line command, such as a subroutine -definition with several statements, you may escape the newline that would -normally end the debugger command with a backslash. Here's an example: +definition with several statements, or a format, you may escape the +newline that would normally end the debugger command with a backslash. +Here's an example: DB<1> for (1..4) { \ cont: print "ok\n"; \ @@ -572,7 +620,10 @@ normally end the debugger command with a backslash. Here's an example: Note that this business of escaping a newline is specific to interactive commands typed into the debugger. -Here's an example of what a stack back-trace might look like: +=item Stack backtrace + +Here's an example of what a stack back-trace via C command might +look like: $ = main::infested called from file `Ambulation.pm' line 10 @ = Ambulation::legs(1, 2, 3, 4) called from file `camel_flea' line 7 @@ -589,6 +640,160 @@ I file with four arguments. The last stack frame shows that C was called in a scalar context, also from I, but from line 4. +Note that if you execute C command from inside an active C +statement, the backtrace will contain both C> +frame and an C>) frame. + +=item Listing + +Listing given via different flavors of C command looks like this: + + DB<<13>> l + 101: @i{@i} = (); + 102:b @isa{@i,$pack} = () + 103 if(exists $i{$prevpack} || exists $isa{$pack}); + 104 } + 105 + 106 next + 107==> if(exists $isa{$pack}); + 108 + 109:a if ($extra-- > 0) { + 110: %isa = ($pack,1); + +Note that the breakable lines are marked with C<:>, lines with +breakpoints are marked by C, with actions by C, and the +next executed line is marked by C<==E>. + +=item Frame listing + +When C option is set, debugger would print entered (and +optionally exited) subroutines in different styles. + +What follows is the start of the listing of + + env "PERLDB_OPTS=f=1 N" perl -d -V + +=over 4 + +=item 1 + + entering main::BEGIN + entering Config::BEGIN + Package lib/Exporter.pm. + Package lib/Carp.pm. + Package lib/Config.pm. + entering Config::TIEHASH + entering Exporter::import + entering Exporter::export + entering Config::myconfig + entering Config::FETCH + entering Config::FETCH + entering Config::FETCH + entering Config::FETCH + +=item 2 + + entering main::BEGIN + entering Config::BEGIN + Package lib/Exporter.pm. + Package lib/Carp.pm. + exited Config::BEGIN + Package lib/Config.pm. + entering Config::TIEHASH + exited Config::TIEHASH + entering Exporter::import + entering Exporter::export + exited Exporter::export + exited Exporter::import + exited main::BEGIN + entering Config::myconfig + entering Config::FETCH + exited Config::FETCH + entering Config::FETCH + exited Config::FETCH + entering Config::FETCH + +=item 4 + + in $=main::BEGIN() from /dev/nul:0 + in $=Config::BEGIN() from lib/Config.pm:2 + Package lib/Exporter.pm. + Package lib/Carp.pm. + Package lib/Config.pm. + in $=Config::TIEHASH('Config') from lib/Config.pm:644 + in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from li + in @=Config::myconfig() from /dev/nul:0 + in $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'SUBVERSION') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'osname') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'osvers') from lib/Config.pm:574 + +=item 6 + + in $=main::BEGIN() from /dev/nul:0 + in $=Config::BEGIN() from lib/Config.pm:2 + Package lib/Exporter.pm. + Package lib/Carp.pm. + out $=Config::BEGIN() from lib/Config.pm:0 + Package lib/Config.pm. + in $=Config::TIEHASH('Config') from lib/Config.pm:644 + out $=Config::TIEHASH('Config') from lib/Config.pm:644 + in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/ + out $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/ + out $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + out $=main::BEGIN() from /dev/nul:0 + in @=Config::myconfig() from /dev/nul:0 + in $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574 + out $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574 + out $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574 + out $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'SUBVERSION') from lib/Config.pm:574 + +=item 14 + + in $=main::BEGIN() from /dev/nul:0 + in $=Config::BEGIN() from lib/Config.pm:2 + Package lib/Exporter.pm. + Package lib/Carp.pm. + out $=Config::BEGIN() from lib/Config.pm:0 + Package lib/Config.pm. + in $=Config::TIEHASH('Config') from lib/Config.pm:644 + out $=Config::TIEHASH('Config') from lib/Config.pm:644 + in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/E + out $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/E + out $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + out $=main::BEGIN() from /dev/nul:0 + in @=Config::myconfig() from /dev/nul:0 + in $=Config::FETCH('Config=HASH(0x1aa444)', 'package') from lib/Config.pm:574 + out $=Config::FETCH('Config=HASH(0x1aa444)', 'package') from lib/Config.pm:574 + in $=Config::FETCH('Config=HASH(0x1aa444)', 'baserev') from lib/Config.pm:574 + out $=Config::FETCH('Config=HASH(0x1aa444)', 'baserev') from lib/Config.pm:574 + +=back + +In all the cases indentation of lines shows the call tree, if bit 2 of +C is set, then a line is printed on exit from a subroutine as +well, if bit 4 is set, then the arguments are printed as well as the +caller info, if bit 8 is set, the arguments are printed even if they +are tied or references. + +When a package is compiled, a line like this + + Package lib/Carp.pm. + +is printed with proper indentation. + +=back + +=head2 Debugging compile-time statements + If you have any compile-time executable statements (code within a BEGIN block or a C statement), these will C be stopped by debugger, although Cs will (and compile-time statements can be traced @@ -604,6 +809,15 @@ just typed the C command, whereas a value of 1 means the C command. The C<$DB::trace> variable should be set to 1 to simulate having typed the C command. +Another way to debug compile-time code is to start debugger, set a +breakpoint on I of some module thusly + + DB<7> b load f:/perllib/lib/Carp.pm + Will stop on load of `f:/perllib/lib/Carp.pm'. + +and restart debugger by C command (if possible). One can use C for the same purpose. + =head2 Debugger Customization Most probably you not want to modify the debugger, it contains enough @@ -647,6 +861,10 @@ the Term::ReadKey and Term::ReadLine modules from CPAN, you will have full editing capabilities much like GNU I(3) provides. Look for these in the F directory on CPAN. +A rudimentary command-line completion is also available. +Unfortunately, the names of lexical variables are not available for +completion. + =head2 Editor Support for Debugging If you have GNU B installed on your system, it can interact with @@ -683,9 +901,9 @@ in that profile. =head2 Debugger support in perl -When you call the B function from package DB, Perl sets the -C<@DB::args> array to contain the arguments that stack frame was called -with. +When you call the B function (see L) from the +package DB, Perl sets the array @DB::args to contain the arguments the +corresponding stack frame was called with. If perl is run with B<-d> option, the following additional features are enabled: @@ -752,7 +970,7 @@ a breakpoint, a call to C is performed if any one of variables $DB::trace, $DB::single, or $DB::signal is true. (Note that these variables are not Cizable.) This feature is disabled when the control is inside C or functions called from it (unless -C<$^D & 1 EE 30>). +C<$^D & (1EE30)>). =item * @@ -764,10 +982,42 @@ in the package C.) =back Note that no subroutine call is possible until C<&DB::sub> is defined -(for subroutines outside of package C). (In fact, for the -standard debugger the same is true if C<$DB::deep> (how many levels of -recursion deep into the debugger you can go before a mandatory break) -is not defined.) +(for subroutines outside of package C). (This restriction is +recently lifted.) + +(In fact, for the standard debugger the same is true if C<$DB::deep> +(how many levels of recursion deep into the debugger you can go before +a mandatory break) is not defined.) + +With the recent updates the minimal possible debugger consists of one +line + + sub DB::DB {} + +which is quite handy as contents of C environment +variable: + + env "PERL5DB=sub DB::DB {}" perl -d your-script + +Another (a little bit more useful) minimal debugger can be created +with the only line being + + sub DB::DB {print ++$i; scalar } + +This debugger would print the sequential number of encountered +statement, and would wait for your C to continue. + +The following debugger is quite functional: + + { + package DB; + sub DB {} + sub sub {print ++$i, " $sub\n"; &$sub} + } + +It prints the sequential number of subroutine call and the name of the +called subroutine. Note that C<&DB::sub> should be compiled into the +package C. =head2 Debugger Internals diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d08d2dc452..68cc69d758 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -799,6 +799,12 @@ Perhaps you need to copy the value to a temporary, and repeat that. (F) The create routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. +=item Cannot resolve method `%s' overloading `%s' in package `%s' + +(F|P) Error resolving overloading specified by a method name (as +opposed to a subroutine reference): no such method callable via the +package. If method name is C, this is an internal error. + =item chmod: mode argument is missing initial 0 (W) A novice will sometimes say @@ -823,6 +829,10 @@ the return value of your socket() call? See L. inlining. See L for commentary and workarounds. +=item Copy method did not return a reference + +(F) The method which overloads "=" is buggy. See L. + =item Corrupt malloc ptr 0x%lx at 0x%lx (P) The malloc package that comes with Perl had an internal failure. @@ -1177,7 +1187,7 @@ assume that an unbackslashed @ interpolates an array.) =item Method for operation %s not found in package %s during blessing (F) An attempt was made to specify an entry in an overloading table that -doesn't somehow point to a valid method. See L. +doesn't resolve to a valid subroutine. See L. =item Might be a runaway multi-line %s string starting on line %d @@ -1420,7 +1430,7 @@ subroutine), but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See also L. -=item Not a subroutine reference in %OVERLOAD +=item Not a subroutine reference in overload table (F) An attempt was made to specify an entry in an overloading table that doesn't somehow point to a valid subroutine. See L. @@ -1487,21 +1497,13 @@ will extend the buffer and zero pad the new area. (S) An internal warning that the grammar is screwed up. -=item Operation `%s' %s: no method found, - -(F) An attempt was made to use an entry in an overloading table that -somehow no longer points to a valid method. See L. - -=item Stub found while resolving method `%s' overloading `%s' in package `%s' - -(P) Overloading resolution over @ISA tree may be broken by importing stubs. -Stubs should never be implicitely created, but explicit calls to C -may break this. +=item Operation `%s': no method found,%s -=item Cannot resolve method `%s' overloading `%s' in package `s' - -(P) Internal error trying to resolve overloading specified by a method -name (as opposed to a subroutine reference). +(F) An attempt was made to perform an overloaded operation for which +no handler was defined. While some handlers can be autogenerated in +terms of other handlers, there is no default handler for any +operation, unless C overloading key is specified to be +true. See L. =item Operator or semicolon missing before %s @@ -2002,6 +2004,12 @@ there was a failure. You probably wanted to use system() instead, which does return. To suppress this warning, put the exec() in a block by itself. +=item Stub found while resolving method `%s' overloading `%s' in package `%s' + +(P) Overloading resolution over @ISA tree may be broken by importation stubs. +Stubs should never be implicitely created, but explicit calls to C +may break this. + =item Subroutine %s redefined (W) You redefined a subroutine. To suppress this warning, say diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 488c797c65..34d9281835 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -408,8 +408,17 @@ With EXPR, it returns some extra information that the debugger uses to print a stack trace. The value of EXPR indicates how many call frames to go back before the current one. - ($package, $filename, $line, - $subroutine, $hasargs, $wantarray) = caller($i); + ($package, $filename, $line, $subroutine, + $hasargs, $wantarray, $evaltext, $is_require) = caller($i); + +Here $subroutine may be C<"(eval)"> if the frame is not a subroutine +call, but C>. In such a case additional elements $evaltext and +$is_require are set: $is_require is true if the frame is created by +C> or C> statement, $evaltext contains the text of +C> statement. In particular, for C> +statement $filename is C<"(eval)">, but $evaltext is undefined. (Note +also that C> statement creates a C> frame inside +an C>) frame. Furthermore, when called from within the DB package, caller returns more detailed information: it sets the list variable @DB::args to be the diff --git a/pod/perlop.pod b/pod/perlop.pod index dd3aeab663..55108f0328 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -737,6 +737,32 @@ The last example should print: Note how C matches change the value reported by C, but the non-global match doesn't. +A useful idiom for C-like scanners is C. You can +combine several regexps like this to process a string part-by-part, +doing different actions depending on which regexp matched. The next +regexp would step in at the place the previous one left off. + + $_ = <<'EOL'; + $url = new URI::URL "http://www/"; die if $url eq "xXx"; +EOL + LOOP: + { + print(" digits"), redo LOOP if /\G\d+\b[,.;]?\s*/g; + print(" lowercase"), redo LOOP if /\G[a-z]+\b[,.;]?\s*/g; + print(" UPPERCASE"), redo LOOP if /\G[A-Z]+\b[,.;]?\s*/g; + print(" Capitalized"), redo LOOP if /\G[A-Z][a-z]+\b[,.;]?\s*/g; + print(" MiXeD"), redo LOOP if /\G[A-Za-z]+\b[,.;]?\s*/g; + print(" alphanumeric"), redo LOOP if /\G[A-Za-z0-9]+\b[,.;]?\s*/g; + print(" line-noise"), redo LOOP if /\G[^A-Za-z0-9]+/g; + print ". That's all!\n"; + } + +Here is the output (split into several lines): + + line-noise lowercase line-noise lowercase UPPERCASE line-noise + UPPERCASE line-noise lowercase line-noise lowercase line-noise + lowercase lowercase line-noise lowercase lowercase line-noise + MiXeD line-noise. That's all! =item q/STRING/ diff --git a/pod/perlre.pod b/pod/perlre.pod index a4c0a7d9de..cb3ce032d0 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -175,7 +175,11 @@ just like "^" and "$" except that they won't match multiple times when the C modifier is used, while "^" and "$" will match at every internal line boundary. To match the actual end of the string, not ignoring newline, you can use C<\Z(?!\n)>. The C<\G> assertion can be used to mix global -matches (using C) and non-global ones, as described in L. +matches (using C) and non-global ones, as described in +L. +It is also useful when writing C-like scanners, when you have several +regexps which you want to match against consequent substrings of your +string, see the previous reference. The actual location where C<\G> will match can also be influenced by using C as an lvalue. See L. diff --git a/pod/perlxs.pod b/pod/perlxs.pod index 26418b51a9..35d74e9eed 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -167,7 +167,21 @@ be received by Perl as the return value of the XSUB. If the XSUB has a return type of C then the compiler will not supply a RETVAL variable for that function. When using -the PPCODE: directive the RETVAL variable may not be needed. +the PPCODE: directive the RETVAL variable is not needed, unless used +explicitly. + +If PPCODE: directive is not used, C return value should be used +only for subroutines which do not return a value, I CODE: +directive is used which sets ST(0) explicitly. + +Older versions of this document recommended to use C return +value in such cases. It was discovered that this could lead to +segfaults in cases when XSUB was I C. This practice is +now deprecated, and may be not supported at some future version. Use +the return value C in such cases. (Currently C contains +some heuristic code which tries to disambiguate between "truely-void" +and "old-practice-declared-as-void" functions. Hence your code is at +mercy of this heuristics unless you use C as return value.) =head2 The MODULE Keyword @@ -570,13 +584,13 @@ of $timep will either be undef or it will be a valid time. $timep = rpcb_gettime( "localhost" ); -The following XSUB uses the C return type to disable the generation of -the RETVAL variable and uses a CODE: block to indicate to the compiler +The following XSUB uses the C return type as a mneumonic only, +and uses a CODE: block to indicate to the compiler that the programmer has supplied all the necessary code. The sv_newmortal() call will initialize the return value to undef, making that the default return value. - void + SV * rpcb_gettime(host) char * host PREINIT: @@ -590,7 +604,7 @@ the default return value. The next example demonstrates how one would place an explicit undef in the return value, should the need arise. - void + SV * rpcb_gettime(host) char * host PREINIT: @@ -1102,7 +1116,7 @@ File C: Interface to some ONC+ RPC bind library functions. MODULE = RPC PACKAGE = RPC - void + SV * rpcb_gettime(host="localhost") char *host PREINIT: -- cgit v1.2.1 From fd2d0953290ddd46f0820dbd6c87245486b7ab28 Mon Sep 17 00:00:00 2001 From: Larry Wall Date: Mon, 20 Jan 1997 15:13:42 -0800 Subject: Nested here-docs p5p-msgid: <199701202313.PAA11693@wall.org> --- toke.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/toke.c b/toke.c index 24805a7d38..af85355f40 100644 --- a/toke.c +++ b/toke.c @@ -4610,10 +4610,11 @@ register char *s; char term; register char *d; char *peek; + int outer = (rsfp && !lex_inwhat); s += 2; d = tokenbuf; - if (!rsfp) + if (!outer) *d++ = '\n'; for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ; if (*peek && strchr("`'\"",*peek)) { @@ -4638,7 +4639,7 @@ register char *s; *d = '\0'; len = d - tokenbuf; d = "\n"; - if (rsfp || !(d=ninstr(s,bufend,d,d+1))) + if (outer || !(d=ninstr(s,bufend,d,d+1))) herewas = newSVpv(s,bufend-s); else s--, herewas = newSVpv(s,d-s); @@ -4659,7 +4660,7 @@ register char *s; multi_start = curcop->cop_line; multi_open = multi_close = '<'; term = *tokenbuf; - if (!rsfp) { + if (!outer) { d = s; while (s < bufend && (*s != term || memNE(s,tokenbuf,len)) ) { @@ -4680,7 +4681,7 @@ register char *s; else sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ while (s >= bufend) { /* multiple line string? */ - if (!rsfp || + if (!outer || !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) { curcop->cop_line = multi_start; missingterm(tokenbuf); -- cgit v1.2.1 From 23f8769697279d7912be5943de9fdf93f6aa3013 Mon Sep 17 00:00:00 2001 From: Stephen Zander Date: Thu, 16 Jan 1997 16:43:52 -0800 Subject: hints & Configure changes to build perl on DC/OSx p5p-msgid: <199701170043.QAA25985@wsbip1.mckesson.com> --- Configure | 3 + hints/dcosx.sh | 188 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 191 insertions(+) create mode 100644 hints/dcosx.sh diff --git a/Configure b/Configure index f9af03cf84..1d5ae4acea 100755 --- a/Configure +++ b/Configure @@ -1707,6 +1707,9 @@ EOM *) osvers=$tmp;; esac ;; + *dc.osx) osname=dcosx + osvers="$3" + ;; dnix) osname=dnix osvers="$3" ;; diff --git a/hints/dcosx.sh b/hints/dcosx.sh new file mode 100644 index 0000000000..3b8a300fa9 --- /dev/null +++ b/hints/dcosx.sh @@ -0,0 +1,188 @@ +# hints/dcosx.sh +# Last modified: Thu Jan 16 11:38:12 EST 1996 +# Stephen Zander +# hints for DC/OSx (Pyramid) & SINIX (Seimens: dc/osx rebadged) +# Based on the hints/solaris_2.sh file + +# See man vfork. +usevfork=false + +d_suidsafe=define + +# Avoid all libraries in /usr/ucblib. +set `echo $glibpth | sed -e 's@/usr/ucblib@@'` +glibpth="$*" + +# Remove bad libraries. +# -lucb contains incompatible routines. +set `echo " $libswanted " | sed -e 's@ ucb @ @'` +libswanted="$*" + +# Here's another draft of the perl5/solaris/gcc sanity-checker. + +case $PATH in +*/usr/ucb*:/usr/bin:*|*/usr/ucb*:/usr/bin) cat <&1 > /dev/null +case $? in +0) ;; +*) + cat </dev/null 2>&1 +case $? in +0) + cat < make.vers 2>&1 +if grep GNU make.vers > /dev/null 2>&1; then + tmp=`/usr/bin/ksh -c "whence make"` + case "`/usr/bin/ls -l $tmp`" in + ??????s*) + cat <&1`" in +*gcc*) + # + # Using gcc. + # + #echo Using gcc + + # Get gcc to share its secrets. + echo 'main() { return 0; }' > try.c + verbose=`${cc:-cc} -v -o try try.c 2>&1` + rm -f try try.c + tmp=`echo "$verbose" | grep '^Reading' | + awk '{print $NF}' | sed 's/specs$/include/'` + + # Determine if the fixed-includes look like they'll work. + # Doesn't work anymore for gcc-2.7.2. + + # See if as(1) is GNU as(1). GNU as(1) won't work for this job. + case $verbose in + */usr/ccs/bin/as*) ;; + *) + cat <&1` in + *GNU*) + cat <&1` in + *GNU*) + cat < Date: Mon, 20 Jan 1997 22:05:39 -0500 Subject: Efficiency patchlet for pp_aassign() Ilya Zakharevich writes: > > With this patch applied the Tom's program > use integer; > @a=map int(rand(30000)), 1..100000; > @b = sort {$a <=> $b} @a; > > Runs in 10.3M (sbrk-en). Here is another tiny patch to pp_aassign: it preallocates the array. Memory saving is not very big for the above script (5%), but the speed advantage may be bigger. [patch] > Memory allocation statistics after compilation: (buckets 8..524288) > 13080 free: 13 109 39 2 13 2 3 2 2 0 0 0 0 0 0 0 0 > 4933288 used: 211 251 519 184 35 6 5 3226 3 0 1 0 0 0 0 0 3 > Total sbrk(): 4960256. Odd ends: sbrk(): 0, malloc(): 1408 bytes. > Memory allocation statistics after execution: (buckets 8..1048576) > 529848 free: 13 109 38 1 13 1 1 2 1 1 1 1 1 1 1 1 0 0 > 9782280 used: 211 251 520 185 35 7 7 5914 4 1 2 1 1 1 1 1 4 1 > Total sbrk(): 10375168. Odd ends: sbrk(): 0, malloc(): 1408 bytes. Here is the new data, note the absense of "tails" of growing arrays. Memory allocation statistics after compilation: (buckets 8..524288) 13080 free: 13 109 39 2 13 2 3 2 2 0 0 0 0 0 0 0 0 4933288 used: 211 251 519 184 35 6 5 3226 3 0 1 0 0 0 0 0 3 Total sbrk(): 4960256. Odd ends: sbrk(): 0, malloc(): 1408 bytes. Memory allocation statistics after execution: (buckets 8..1048576) 11704 free: 13 109 38 1 13 1 3 1 2 0 0 0 0 0 0 0 0 0 9796616 used: 211 251 520 185 35 7 5 6439 3 0 1 0 0 0 0 0 4 1 Total sbrk(): 9830400. Odd ends: sbrk(): 0, malloc(): 1408 bytes. > It is 100 bytes per element. Since an integer array takes 24 bytes per > element here, and there are only 3 arrays around (precalculated > 1..100000, @a and @b), there is some other leak. > > Apparently <=> converts arguments to NV. No, all this is wrong. It is 20bytes/elt, and we have stack, mortals-stack, 1..100000, @a and @b. Everything is OK now, including <=>. Enjoy, p5p-msgid: <199701210305.WAA05451@monk.mps.ohio-state.edu> --- pp_hot.c | 1 + 1 file changed, 1 insertion(+) diff --git a/pp_hot.c b/pp_hot.c index cbc2b95d38..cbc19d5c5e 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -612,6 +612,7 @@ PP(pp_aassign) magic = SvMAGICAL(ary) != 0; av_clear(ary); + av_extend(ary, lastrelem - relem); i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ sv = NEWSV(28,0); -- cgit v1.2.1 From bbad36071d5a6d4be3588f0f10c88247439076d8 Mon Sep 17 00:00:00 2001 From: Ilya Zakharevich Date: Thu, 16 Jan 1997 23:48:18 -0500 Subject: Test patches for OS/2 a) Teaches tests in os2/OS2/*/* new format of $Config{extensions}; os2/OS2/ExtAttr/t/os2_ea.t os2/OS2/PrfDB/t/os2_prfdb.t os2/OS2/REXX/t/rx_cmprt.t os2/OS2/REXX/t/rx_dllld.t os2/OS2/REXX/t/rx_objcall.t os2/OS2/REXX/t/rx_sql.test os2/OS2/REXX/t/rx_tiesql.test os2/OS2/REXX/t/rx_tievar.t os2/OS2/REXX/t/rx_tieydb.t os2/OS2/REXX/t/rx_varset.t os2/OS2/REXX/t/rx_vrexx.t b) Closes all the files before unlinking - for DOSISH systems; t/cmd/while.t t/comp/multiline.t t/io/argv.t t/lib/anydbm.t t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t c) t/README mentions running `harness' to get better granularity; t/README d) New test op/lex_assign.t added - will check optimization of lexicals when applied - 153 cases (some just ignored since hard to implement). MANIFEST t/op/lex_assign.t e) When a script is started via shell, $Config{exe_ext} may be appended. t/op/magic.t f) path/echo may print a warning if run without args t/comp/colon.t g) Error explanations more verbose t/op/cmp.t t/op/magic.t p5p-msgid: <199701170448.XAA28948@monk.mps.ohio-state.edu> --- MANIFEST | 1 + os2/OS2/ExtAttr/t/os2_ea.t | 4 +- os2/OS2/PrfDB/t/os2_prfdb.t | 5 +- os2/OS2/REXX/t/rx_cmprt.t | 2 +- os2/OS2/REXX/t/rx_dllld.t | 2 +- os2/OS2/REXX/t/rx_objcall.t | 2 +- os2/OS2/REXX/t/rx_sql.test | 2 +- os2/OS2/REXX/t/rx_tiesql.test | 2 +- os2/OS2/REXX/t/rx_tievar.t | 2 +- os2/OS2/REXX/t/rx_tieydb.t | 2 +- os2/OS2/REXX/t/rx_varset.t | 2 +- os2/OS2/REXX/t/rx_vrexx.t | 2 +- t/README | 5 + t/cmd/while.t | 1 + t/comp/colon.t | 2 +- t/comp/multiline.t | 2 + t/io/argv.t | 1 + t/lib/anydbm.t | 1 + t/lib/gdbm.t | 1 + t/lib/ndbm.t | 1 + t/lib/odbm.t | 1 + t/lib/sdbm.t | 1 + t/op/cmp.t | 4 +- t/op/lex_assign.t | 214 ++++++++++++++++++++++++++++++++++++++++++ t/op/magic.t | 8 +- 25 files changed, 252 insertions(+), 18 deletions(-) create mode 100644 t/op/lex_assign.t diff --git a/MANIFEST b/MANIFEST index 6b202da522..6a45129282 100644 --- a/MANIFEST +++ b/MANIFEST @@ -657,6 +657,7 @@ t/op/inc.t See if inc/dec of integers near 32 bit limit work t/op/index.t See if index works t/op/int.t See if int works t/op/join.t See if join works +t/op/lex_assign.t See if assignment to lexicals work t/op/list.t See if array lists work t/op/local.t See if local works t/op/magic.t See if magic variables work diff --git a/os2/OS2/ExtAttr/t/os2_ea.t b/os2/OS2/ExtAttr/t/os2_ea.t index dc6f996564..a1da398d45 100644 --- a/os2/OS2/ExtAttr/t/os2_ea.t +++ b/os2/OS2/ExtAttr/t/os2_ea.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } @@ -76,4 +76,4 @@ print "ok 12\n"; } print "ok 21\n"; - +unlink 't.out'; diff --git a/os2/OS2/PrfDB/t/os2_prfdb.t b/os2/OS2/PrfDB/t/os2_prfdb.t index 4c0883db50..a8c9752d36 100644 --- a/os2/OS2/PrfDB/t/os2_prfdb.t +++ b/os2/OS2/PrfDB/t/os2_prfdb.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::PrfDB\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)PrfDB\b/) { print "1..0\n"; exit 0; } @@ -183,3 +183,6 @@ tie %hash2, 'OS2::PrfDB', $inifile; print "ok 47\n"; print ($hash2{nnn}->{mmm} eq "67" ? "ok 48\n" : "not ok 48\n# `$val'\n"); + +untie %hash2; +unlink $inifile; diff --git a/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t index a73e43e36e..f2113e3aa3 100644 --- a/os2/OS2/REXX/t/rx_cmprt.t +++ b/os2/OS2/REXX/t/rx_cmprt.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t index 317743f3cb..9d81bf3e56 100644 --- a/os2/OS2/REXX/t/rx_dllld.t +++ b/os2/OS2/REXX/t/rx_dllld.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t index b4f04c308a..cb3c52a8b6 100644 --- a/os2/OS2/REXX/t/rx_objcall.t +++ b/os2/OS2/REXX/t/rx_objcall.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_sql.test b/os2/OS2/REXX/t/rx_sql.test index 4f984250a3..602c76dc47 100644 --- a/os2/OS2/REXX/t/rx_sql.test +++ b/os2/OS2/REXX/t/rx_sql.test @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bOS2::REXX\b/) { + if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_tiesql.test b/os2/OS2/REXX/t/rx_tiesql.test index 2947516755..c85a1e990b 100644 --- a/os2/OS2/REXX/t/rx_tiesql.test +++ b/os2/OS2/REXX/t/rx_tiesql.test @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bOS2::REXX\b/) { + if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t index 6132e23f80..77f90c2f59 100644 --- a/os2/OS2/REXX/t/rx_tievar.t +++ b/os2/OS2/REXX/t/rx_tievar.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t index 8251051265..30a2dafb62 100644 --- a/os2/OS2/REXX/t/rx_tieydb.t +++ b/os2/OS2/REXX/t/rx_tieydb.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_varset.t b/os2/OS2/REXX/t/rx_varset.t index 9d4f3b2e56..166cf53623 100644 --- a/os2/OS2/REXX/t/rx_varset.t +++ b/os2/OS2/REXX/t/rx_varset.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t index a40749f55f..04ca6636db 100644 --- a/os2/OS2/REXX/t/rx_vrexx.t +++ b/os2/OS2/REXX/t/rx_vrexx.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/t/README b/t/README index 00bf561c23..6fb569b98f 100644 --- a/t/README +++ b/t/README @@ -8,4 +8,9 @@ If you put out extra lines with a '#' character on the front, you don't have to worry about removing the extra print statements later since TEST ignores lines beginning with '#'. +If you know that "basic" features work and expect that some test are going +to fail, it is adviced to run tests via Test::Harness thusly: + ./perl -I../lib harness +This would pinpoint failed tests with better granularity. + If you come up with new tests, send them to larry@wall.org. diff --git a/t/cmd/while.t b/t/cmd/while.t index 4c8c10e990..c6e464d444 100755 --- a/t/cmd/while.t +++ b/t/cmd/while.t @@ -90,6 +90,7 @@ loop: while () { if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} +close(fh) || die "Can't close Cmd_while.tmp."; unlink 'Cmd_while.tmp' || `/bin/rm Cmd_While.tmp`; #$x = 0; diff --git a/t/comp/colon.t b/t/comp/colon.t index 2a37367d75..d2c64fe4c5 100755 --- a/t/comp/colon.t +++ b/t/comp/colon.t @@ -110,7 +110,7 @@ ok 18, (not eval "qw:1" and not eval "qw:echo:ohce: >= 0"); ok 19, (not eval "qx:1" and - eval "qx:echo: eq qx|echo|" and + eval "qx:echo 1: eq qx|echo 1|" and # echo without args may warn not eval "qx:echo:ohce: >= 0"); ok 20, (not eval "s:1" and diff --git a/t/comp/multiline.t b/t/comp/multiline.t index 634b06a7a8..0e022e9992 100755 --- a/t/comp/multiline.t +++ b/t/comp/multiline.t @@ -35,6 +35,8 @@ if ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";} $_ = `cat Comp.try`; if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";} + +close(try) || (die "Can't close temp file."); unlink 'Comp.try' || `/bin/rm -f Comp.try`; if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";} diff --git a/t/io/argv.t b/t/io/argv.t index 40ed23b373..bf592f91cb 100755 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -34,3 +34,4 @@ else {print "not ok 5\n";} `/bin/rm -f Io.argv.tmp` if -x '/bin/rm'; +unlink 'Io.argv.tmp'; diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t index 80b39df141..52ab22b13e 100755 --- a/t/lib/anydbm.t +++ b/t/lib/anydbm.t @@ -111,4 +111,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t index c888c00f85..62bb936ff1 100755 --- a/t/lib/gdbm.t +++ b/t/lib/gdbm.t @@ -114,4 +114,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t index 15aa93a725..8e2ba8164a 100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@ -117,4 +117,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/odbm.t b/t/lib/odbm.t index 0b1fa50cb9..0c530d2238 100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@ -117,4 +117,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t index 1bb3fde392..65419f9711 100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@ -116,4 +116,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/op/cmp.t b/t/op/cmp.t index aba7c2e9dc..4a7e68d448 100755 --- a/t/op/cmp.t +++ b/t/op/cmp.t @@ -18,7 +18,7 @@ for my $i (0..$#FOO) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] <=> $FOO[$j])\n"; + print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; } $ok++; $cmp = $FOO[$i] cmp $FOO[$j]; @@ -29,7 +29,7 @@ for my $i (0..$#FOO) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] cmp $FOO[$j])\n"; + print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; } } } diff --git a/t/op/lex_assign.t b/t/op/lex_assign.t new file mode 100644 index 0000000000..d35f39c2c3 --- /dev/null +++ b/t/op/lex_assign.t @@ -0,0 +1,214 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +umask 0; +$xref = \ ""; +@a = (1..5); +%h = (1..6); +$aref = \@a; +$href = \%h; +open OP, qq{$^X -le 'print "aaa Ok ok" while \$i++ < 100'|}; +$chopit = 'aaaaaa'; +@chopar = (113 .. 119); +$posstr = '123456'; +$cstr = 'aBcD.eF'; +pos $posstr = 3; +$nn = $n = 2; +sub subb {"in s"} + +@INPUT = ; +print "1..", (scalar @INPUT), "\n"; +$ord = 0; + +sub wrn {"@_"} + +for (@INPUT) { + $ord++; + ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; + $comment = $op unless defined $comment; + $op = "$op==$op" unless $op =~ /==/; + ($op, $expectop) = $op =~ /(.*)==(.*)/; + + $skip = ($op =~ /^'\?\?\?'/) ? "skip" : "not"; + $integer = ($comment =~ /^i_/) ? "use integer" : '' ; + (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; + + eval < # glob + # readline +'faked' # rcatline +(@z = (1 .. 3)) # aassign +chop $chopit # chop +(chop (@x=@chopar)) # schop +chomp $chopit # chomp +(chop (@x=@chopar)) # schomp +pos $posstr # pos +pos $chopit # pos returns undef +$nn++==2 # postinc +$nn++==3 # i_postinc +$nn--==4 # postdec +$nn--==3 # i_postdec +$n ** $n # pow +$n * $n # multiply +$n * $n # i_multiply +$n / $n # divide +$n / $n # i_divide +$n % $n # modulo +$n % $n # i_modulo +$n x $n # repeat +$n + $n # add +$n + $n # i_add +$n - $n # subtract +$n - $n # i_subtract +$n . $n # concat +$n . $a=='2fake' # concat with self +"3$a"=='3fake' # concat with self in stringify +"$n" # stringify +$n << $n # left_shift +$n >> $n # right_shift +$n <=> $n # ncmp +$n <=> $n # i_ncmp +$n cmp $n # scmp +$n & $n # bit_and +$n ^ $n # bit_xor +$n | $n # bit_or +-$n # negate +-$n # i_negate +~$n # complement +atan2 $n,$n # atan2 +sin $n # sin +cos $n # cos +'???' # rand +exp $n # exp +log $n # log +sqrt $n # sqrt +int $n # int +hex $n # hex +oct $n # oct +abs $n # abs +length $posstr # length +substr $posstr, 2, 2 # substr +vec("abc",2,8) # vec +index $posstr, 2 # index +rindex $posstr, 2 # rindex +sprintf "%i%i", $n, $n # sprintf +ord $n # ord +chr $n # chr +crypt $n, $n # crypt +ucfirst ($cstr . "a") # ucfirst padtmp +ucfirst $cstr # ucfirst +lcfirst $cstr # lcfirst +uc $cstr # uc +lc $cstr # lc +quotemeta $cstr # quotemeta +@$aref # rv2av +@$undefed # rv2av undef +each %h==1 # each +values %h # values +keys %h # keys +%$href # rv2hv +pack "C2", $n,$n # pack +split /a/, "abad" # split +join "a"; @a # join +push @a,3==6 # push +unshift @aaa # unshift +reverse @a # reverse +reverse $cstr # reverse - scal +grep $_, 1,0,2,0,3 # grepwhile +map "x$_", 1,0,2,0,3 # mapwhile +subb() # entersub +caller # caller +warn "ignore this\n" # warn +'faked' # die +open BLAH, "