PERFORCE change 11422 for review
[email protected] (Chris Nandor) Fri, 20 Jul 2001 15:37:10 -0400
| Newsgroups | perl.perl5.changes.mac |
|---|---|
| Message-ID | <p05100303b77e38c307c9@[10.0.1.107]> |
Change 11422 by pudge@pudge-mobile on 2001/07/20 18:16:37
Add Filter::Util::Call, Class::ISA, Digest, Filter::Simple,
Switch, and Text::Balanced.
Affected files ...
... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Call.pm#1 add
... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Call.xs#1 add
... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Makefile.PL#1 add
... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/MyFilter.pm#1 add
... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/call.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/filter-util.pl#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Class/ISA.pm#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Digest.pm#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Filter/Simple.pm#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Switch.pm#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Text/Balanced.pm#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Text/Balanced.pod#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Class/ISA/test.pl#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Digest/Digest.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/test.pl#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Switch/test.pl#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/genxt.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xbrak.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xcode.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xdeli.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xmult.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xquot.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xtagg.t#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xvari.t#1 add
Differences ...
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Call.pm#1 (text) ====
Index: perl/macos/bundled_ext/Filter/Util/Call/Call.pm
--- perl/macos/bundled_ext/Filter/Util/Call/Call.pm.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_ext/Filter/Util/Call/Call.pm Fri Jul 20 12:30:05 2001
@@ -0,0 +1,498 @@
+
+# Call.pm
+#
+# Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Filter::Util::Call ;
+
+require 5.002 ;
+require DynaLoader;
+require Exporter;
+use Carp ;
+use strict;
+use warnings;
+use vars qw($VERSION @ISA @EXPORT) ;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ;
+$VERSION = "1.05" ;
+
+sub filter_read_exact($)
+{
+ my ($size) = @_ ;
+ my ($left) = $size ;
+ my ($status) ;
+
+ croak ("filter_read_exact: size parameter must be > 0")
+ unless $size > 0 ;
+
+ # try to read a block which is exactly $size bytes long
+ while ($left and ($status = filter_read($left)) > 0) {
+ $left = $size - length $_ ;
+ }
+
+ # EOF with pending data is a special case
+ return 1 if $status == 0 and length $_ ;
+
+ return $status ;
+}
+
+sub filter_add($)
+{
+ my($obj) = @_ ;
+
+ # Did we get a code reference?
+ my $coderef = (ref $obj eq 'CODE') ;
+
+ # If the parameter isn't already a reference, make it one.
+ $obj = \$obj unless ref $obj ;
+
+ $obj = bless ($obj, (caller)[0]) unless $coderef ;
+
+ # finish off the installation of the filter in C.
+ Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ;
+}
+
+bootstrap Filter::Util::Call ;
+
+1;
+__END__
+
+=head1 NAME
+
+Filter::Util::Call - Perl Source Filter Utility Module
+
+=head1 SYNOPSIS
+
+ use Filter::Util::Call ;
+
+=head1 DESCRIPTION
+
+This module provides you with the framework to write I<Source Filters>
+in Perl.
+
+An alternate interface to Filter::Util::Call is now available. See
+L<Filter::Simple> for more details.
+
+A I<Perl Source Filter> is implemented as a Perl module. The structure
+of the module can take one of two broadly similar formats. To
+distinguish between them, the first will be referred to as I<method
+filter> and the second as I<closure filter>.
+
+Here is a skeleton for the I<method filter>:
+
+ package MyFilter ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type, @arguments) = @_ ;
+ filter_add([]) ;
+ }
+
+ sub filter
+ {
+ my($self) = @_ ;
+ my($status) ;
+
+ $status = filter_read() ;
+ $status ;
+ }
+
+ 1 ;
+
+and this is the equivalent skeleton for the I<closure filter>:
+
+ package MyFilter ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type, @arguments) = @_ ;
+
+ filter_add(
+ sub
+ {
+ my($status) ;
+ $status = filter_read() ;
+ $status ;
+ } )
+ }
+
+ 1 ;
+
+To make use of either of the two filter modules above, place the line
+below in a Perl source file.
+
+ use MyFilter;
+
+In fact, the skeleton modules shown above are fully functional I<Source
+Filters>, albeit fairly useless ones. All they does is filter the
+source stream without modifying it at all.
+
+As you can see both modules have a broadly similar structure. They both
+make use of the C<Filter::Util::Call> module and both have an C<import>
+method. The difference between them is that the I<method filter>
+requires a I<filter> method, whereas the I<closure filter> gets the
+equivalent of a I<filter> method with the anonymous sub passed to
+I<filter_add>.
+
+To make proper use of the I<closure filter> shown above you need to
+have a good understanding of the concept of a I<closure>. See
+L<perlref> for more details on the mechanics of I<closures>.
+
+=head2 B<use Filter::Util::Call>
+
+The following functions are exported by C<Filter::Util::Call>:
+
+ filter_add()
+ filter_read()
+ filter_read_exact()
+ filter_del()
+
+=head2 B<import()>
+
+The C<import> method is used to create an instance of the filter. It is
+called indirectly by Perl when it encounters the C<use MyFilter> line
+in a source file (See L<perlfunc/import> for more details on
+C<import>).
+
+It will always have at least one parameter automatically passed by Perl
+- this corresponds to the name of the package. In the example above it
+will be C<"MyFilter">.
+
+Apart from the first parameter, import can accept an optional list of
+parameters. These can be used to pass parameters to the filter. For
+example:
+
+ use MyFilter qw(a b c) ;
+
+will result in the C<@_> array having the following values:
+
+ @_ [0] => "MyFilter"
+ @_ [1] => "a"
+ @_ [2] => "b"
+ @_ [3] => "c"
+
+Before terminating, the C<import> function must explicitly install the
+filter by calling C<filter_add>.
+
+B<filter_add()>
+
+The function, C<filter_add>, actually installs the filter. It takes one
+parameter which should be a reference. The kind of reference used will
+dictate which of the two filter types will be used.
+
+If a CODE reference is used then a I<closure filter> will be assumed.
+
+If a CODE reference is not used, a I<method filter> will be assumed.
+In a I<method filter>, the reference can be used to store context
+information. The reference will be I<blessed> into the package by
+C<filter_add>.
+
+See the filters at the end of this documents for examples of using
+context information using both I<method filters> and I<closure
+filters>.
+
+=head2 B<filter() and anonymous sub>
+
+Both the C<filter> method used with a I<method filter> and the
+anonymous sub used with a I<closure filter> is where the main
+processing for the filter is done.
+
+The big difference between the two types of filter is that the I<method
+filter> uses the object passed to the method to store any context data,
+whereas the I<closure filter> uses the lexical variables that are
+maintained by the closure.
+
+Note that the single parameter passed to the I<method filter>,
+C<$self>, is the same reference that was passed to C<filter_add>
+blessed into the filter's package. See the example filters later on for
+details of using C<$self>.
+
+Here is a list of the common features of the anonymous sub and the
+C<filter()> method.
+
+=over 5
+
+=item B<$_>
+
+Although C<$_> doesn't actually appear explicitly in the sample filters
+above, it is implicitly used in a number of places.
+
+Firstly, when either C<filter> or the anonymous sub are called, a local
+copy of C<$_> will automatically be created. It will always contain the
+empty string at this point.
+
+Next, both C<filter_read> and C<filter_read_exact> will append any
+source data that is read to the end of C<$_>.
+
+Finally, when C<filter> or the anonymous sub are finished processing,
+they are expected to return the filtered source using C<$_>.
+
+This implicit use of C<$_> greatly simplifies the filter.
+
+=item B<$status>
+
+The status value that is returned by the user's C<filter> method or
+anonymous sub and the C<filter_read> and C<read_exact> functions take
+the same set of values, namely:
+
+ < 0 Error
+ = 0 EOF
+ > 0 OK
+
+=item B<filter_read> and B<filter_read_exact>
+
+These functions are used by the filter to obtain either a line or block
+from the next filter in the chain or the actual source file if there
+aren't any other filters.
+
+The function C<filter_read> takes two forms:
+
+ $status = filter_read() ;
+ $status = filter_read($size) ;
+
+The first form is used to request a I<line>, the second requests a
+I<block>.
+
+In line mode, C<filter_read> will append the next source line to the
+end of the C<$_> scalar.
+
+In block mode, C<filter_read> will append a block of data which is <=
+C<$size> to the end of the C<$_> scalar. It is important to emphasise
+the that C<filter_read> will not necessarily read a block which is
+I<precisely> C<$size> bytes.
+
+If you need to be able to read a block which has an exact size, you can
+use the function C<filter_read_exact>. It works identically to
+C<filter_read> in block mode, except it will try to read a block which
+is exactly C<$size> bytes in length. The only circumstances when it
+will not return a block which is C<$size> bytes long is on EOF or
+error.
+
+It is I<very> important to check the value of C<$status> after I<every>
+call to C<filter_read> or C<filter_read_exact>.
+
+=item B<filter_del>
+
+The function, C<filter_del>, is used to disable the current filter. It
+does not affect the running of the filter. All it does is tell Perl not
+to call filter any more.
+
+See L<Example 4: Using filter_del> for details.
+
+=back
+
+=head1 EXAMPLES
+
+Here are a few examples which illustrate the key concepts - as such
+most of them are of little practical use.
+
+The C<examples> sub-directory has copies of all these filters
+implemented both as I<method filters> and as I<closure filters>.
+
+=head2 Example 1: A simple filter.
+
+Below is a I<method filter> which is hard-wired to replace all
+occurrences of the string C<"Joe"> to C<"Jim">. Not particularly
+Useful, but it is the first example and I wanted to keep it simple.
+
+ package Joe2Jim ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type) = @_ ;
+
+ filter_add(bless []) ;
+ }
+
+ sub filter
+ {
+ my($self) = @_ ;
+ my($status) ;
+
+ s/Joe/Jim/g
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ }
+
+ 1 ;
+
+Here is an example of using the filter:
+
+ use Joe2Jim ;
+ print "Where is Joe?\n" ;
+
+And this is what the script above will print:
+
+ Where is Jim?
+
+=head2 Example 2: Using the context
+
+The previous example was not particularly useful. To make it more
+general purpose we will make use of the context data and allow any
+arbitrary I<from> and I<to> strings to be used. This time we will use a
+I<closure filter>. To reflect its enhanced role, the filter is called
+C<Subst>.
+
+ package Subst ;
+
+ use Filter::Util::Call ;
+ use Carp ;
+
+ sub import
+ {
+ croak("usage: use Subst qw(from to)")
+ unless @_ == 3 ;
+ my ($self, $from, $to) = @_ ;
+ filter_add(
+ sub
+ {
+ my ($status) ;
+ s/$from/$to/
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ })
+ }
+ 1 ;
+
+and is used like this:
+
+ use Subst qw(Joe Jim) ;
+ print "Where is Joe?\n" ;
+
+
+=head2 Example 3: Using the context within the filter
+
+Here is a filter which a variation of the C<Joe2Jim> filter. As well as
+substituting all occurrences of C<"Joe"> to C<"Jim"> it keeps a count
+of the number of substitutions made in the context object.
+
+Once EOF is detected (C<$status> is zero) the filter will insert an
+extra line into the source stream. When this extra line is executed it
+will print a count of the number of substitutions actually made.
+Note that C<$status> is set to C<1> in this case.
+
+ package Count ;
+
+ use Filter::Util::Call ;
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0 ) {
+ s/Joe/Jim/g ;
+ ++ $$self ;
+ }
+ elsif ($$self >= 0) { # EOF
+ $_ = "print q[Made ${$self} substitutions\n]" ;
+ $status = 1 ;
+ $$self = -1 ;
+ }
+
+ $status ;
+ }
+
+ sub import
+ {
+ my ($self) = @_ ;
+ my ($count) = 0 ;
+ filter_add(\$count) ;
+ }
+
+ 1 ;
+
+Here is a script which uses it:
+
+ use Count ;
+ print "Hello Joe\n" ;
+ print "Where is Joe\n" ;
+
+Outputs:
+
+ Hello Jim
+ Where is Jim
+ Made 2 substitutions
+
+=head2 Example 4: Using filter_del
+
+Another variation on a theme. This time we will modify the C<Subst>
+filter to allow a starting and stopping pattern to be specified as well
+as the I<from> and I<to> patterns. If you know the I<vi> editor, it is
+the equivalent of this command:
+
+ :/start/,/stop/s/from/to/
+
+When used as a filter we want to invoke it like this:
+
+ use NewSubst qw(start stop from to) ;
+
+Here is the module.
+
+ package NewSubst ;
+
+ use Filter::Util::Call ;
+ use Carp ;
+
+ sub import
+ {
+ my ($self, $start, $stop, $from, $to) = @_ ;
+ my ($found) = 0 ;
+ croak("usage: use Subst qw(start stop from to)")
+ unless @_ == 5 ;
+
+ filter_add(
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+
+ $found = 1
+ if $found == 0 and /$start/ ;
+
+ if ($found) {
+ s/$from/$to/ ;
+ filter_del() if /$stop/ ;
+ }
+
+ }
+ $status ;
+ } )
+
+ }
+
+ 1 ;
+
+=head1 Filter::Simple
+
+If you intend using the Filter::Call functionality, I would strongly
+recommend that you check out Damian Conway's excellent Filter::Simple
+module. This module provides a much cleaner interface than
+Filter::Util::Call. Although it doesn't allow the fine control that
+Filter::Util::Call does, it should be adequate for the majority of
+applications. It's available at
+
+ http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
+ http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+26th January 1996
+
+=cut
+
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Call.xs#1 (text) ====
Index: perl/macos/bundled_ext/Filter/Util/Call/Call.xs
--- perl/macos/bundled_ext/Filter/Util/Call/Call.xs.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_ext/Filter/Util/Call/Call.xs Fri Jul 20 12:30:05 2001
@@ -0,0 +1,258 @@
+/*
+ * Filename : Call.xs
+ *
+ * Author : Paul Marquess
+ * Date : 26th March 2000
+ * Version : 1.05
+ *
+ * Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
+ * This program is free software; you can redistribute it and/or
+ * modify it under the same terms as Perl itself.
+ *
+ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifndef PERL_VERSION
+# include "patchlevel.h"
+# define PERL_REVISION 5
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+#endif
+
+/* defgv must be accessed differently under threaded perl */
+/* DEFSV et al are in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(defgv)
+#endif
+
+#ifndef pTHX
+# define pTHX
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+
+/* Internal defines */
+#define PERL_MODULE(s) IoBOTTOM_NAME(s)
+#define PERL_OBJECT(s) IoTOP_GV(s)
+#define FILTER_ACTIVE(s) IoLINES(s)
+#define BUF_OFFSET(sv) IoPAGE_LEN(sv)
+#define CODE_REF(sv) IoPAGE(sv)
+
+#define SET_LEN(sv,len) \
+ do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
+
+
+
+static int fdebug = 0;
+static int current_idx ;
+
+static I32
+filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
+{
+ SV *my_sv = FILTER_DATA(idx);
+ char *nl = "\n";
+ char *p;
+ char *out_ptr;
+ int n;
+
+ if (fdebug)
+ warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n",
+ maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
+
+ while (1) {
+
+ /* anything left from last time */
+ if ((n = SvCUR(my_sv))) {
+
+ out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
+
+ if (maxlen) {
+ /* want a block */
+ if (fdebug)
+ warn("BLOCK(%d): size = %d, maxlen = %d\n",
+ idx, n, maxlen) ;
+
+ sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
+ if(n <= maxlen) {
+ BUF_OFFSET(my_sv) = 0 ;
+ SET_LEN(my_sv, 0) ;
+ }
+ else {
+ BUF_OFFSET(my_sv) += maxlen ;
+ SvCUR_set(my_sv, n - maxlen) ;
+ }
+ return SvCUR(buf_sv);
+ }
+ else {
+ /* want lines */
+ if ((p = ninstr(out_ptr, out_ptr + n - 1, nl, nl))) {
+
+ sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
+
+ n = n - (p - out_ptr + 1);
+ BUF_OFFSET(my_sv) += (p - out_ptr + 1);
+ SvCUR_set(my_sv, n) ;
+ if (fdebug)
+ warn("recycle %d - leaving %d, returning %d [%s]",
+ idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
+
+ return SvCUR(buf_sv);
+ }
+ else /* no EOL, so append the complete buffer */
+ sv_catpvn(buf_sv, out_ptr, n) ;
+ }
+
+ }
+
+
+ SET_LEN(my_sv, 0) ;
+ BUF_OFFSET(my_sv) = 0 ;
+
+ if (FILTER_ACTIVE(my_sv))
+ {
+ dSP ;
+ int count ;
+
+ if (fdebug)
+ warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
+
+ ENTER ;
+ SAVETMPS;
+
+ SAVEINT(current_idx) ; /* save current idx */
+ current_idx = idx ;
+
+ SAVESPTR(DEFSV) ; /* save $_ */
+ /* make $_ use our buffer */
+ DEFSV = sv_2mortal(newSVpv("", 0)) ;
+
+ PUSHMARK(sp) ;
+
+ if (CODE_REF(my_sv)) {
+ /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
+ count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
+ }
+ else {
+ XPUSHs((SV*)PERL_OBJECT(my_sv)) ;
+
+ PUTBACK ;
+
+ count = perl_call_method("filter", G_SCALAR);
+ }
+
+ SPAGAIN ;
+
+ if (count != 1)
+ croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n",
+ PERL_MODULE(my_sv), count ) ;
+
+ n = POPi ;
+
+ if (fdebug)
+ warn("status = %d, length op buf = %d [%s]\n",
+ n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
+ if (SvCUR(DEFSV))
+ sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ }
+ else
+ n = FILTER_READ(idx + 1, my_sv, maxlen) ;
+
+ if (n <= 0)
+ {
+ /* Either EOF or an error */
+
+ if (fdebug)
+ warn ("filter_read %d returned %d , returning %d\n", idx, n,
+ (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
+
+ /* PERL_MODULE(my_sv) ; */
+ /* PERL_OBJECT(my_sv) ; */
+ filter_del(filter_call);
+
+ /* If error, return the code */
+ if (n < 0)
+ return n ;
+
+ /* return what we have so far else signal eof */
+ return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
+ }
+
+ }
+}
+
+
+
+MODULE = Filter::Util::Call PACKAGE = Filter::Util::Call
+
+REQUIRE: 1.924
+PROTOTYPES: ENABLE
+
+#define IDX current_idx
+
+int
+filter_read(size=0)
+ int size
+ CODE:
+ {
+ SV * buffer = DEFSV ;
+
+ RETVAL = FILTER_READ(IDX + 1, buffer, size) ;
+ }
+ OUTPUT:
+ RETVAL
+
+
+
+
+void
+real_import(object, perlmodule, coderef)
+ SV * object
+ char * perlmodule
+ int coderef
+ PPCODE:
+ {
+ SV * sv = newSV(1) ;
+
+ (void)SvPOK_only(sv) ;
+ filter_add(filter_call, sv) ;
+
+ PERL_MODULE(sv) = savepv(perlmodule) ;
+ PERL_OBJECT(sv) = (GV*) newSVsv(object) ;
+ FILTER_ACTIVE(sv) = TRUE ;
+ BUF_OFFSET(sv) = 0 ;
+ CODE_REF(sv) = coderef ;
+
+ SvCUR_set(sv, 0) ;
+
+ }
+
+void
+filter_del()
+ CODE:
+ FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
+
+
+
+void
+unimport(package="$Package", ...)
+ char *package
+ PPCODE:
+ filter_del(filter_call);
+
+
+BOOT:
+ /* temporary hack to control debugging in toke.c */
+ if (fdebug)
+ filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
+
+
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Makefile.PL#1 (text) ====
Index: perl/macos/bundled_ext/Filter/Util/Call/Makefile.PL
--- perl/macos/bundled_ext/Filter/Util/Call/Makefile.PL.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_ext/Filter/Util/Call/Makefile.PL Fri Jul 20 12:30:05 2001
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Filter::Util::Call',
+ VERSION_FROM => 'Call.pm',
+ MAN3PODS => {}, # Pods will be built by installman.
+);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/MyFilter.pm#1 (text) ====
Index: perl/macos/bundled_ext/Filter/t/MyFilter.pm
--- perl/macos/bundled_ext/Filter/t/MyFilter.pm.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_ext/Filter/t/MyFilter.pm Fri Jul 20 12:30:05 2001
@@ -0,0 +1,14 @@
+package MyFilter;
+
+BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+}
+
+use Filter::Simple sub {
+ while (my ($from, $to) = splice @_, 0, 2) {
+ s/$from/$to/g;
+ }
+};
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/call.t#1 (text) ====
Index: perl/macos/bundled_ext/Filter/t/call.t
--- perl/macos/bundled_ext/Filter/t/call.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_ext/Filter/t/call.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,795 @@
+BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) {
+ print "1..0 # Skip: Filter::Util::Call was not built\n";
+ exit 0;
+ }
+ require 'lib/filter-util.pl';
+}
+
+use strict;
+use warnings;
+
+use vars qw($Inc $Perl);
+
+print "1..28\n" ;
+
+$Perl = "$Perl -w" ;
+
+use Cwd ;
+my $here = getcwd ;
+
+
+my $filename = "call.tst" ;
+my $filenamebin = "call.bin" ;
+my $module = "MyTest" ;
+my $module2 = "MyTest2" ;
+my $module3 = "MyTest3" ;
+my $module4 = "MyTest4" ;
+my $module5 = "MyTest5" ;
+my $nested = "nested" ;
+my $block = "block" ;
+
+# Test error cases
+##################
+
+# no filter function in module
+###############################
+
+writeFile("${module}.pm", <<EOM) ;
+package ${module} ;
+
+use Filter::Util::Call ;
+
+sub import { filter_add(bless []) }
+
+1 ;
+EOM
+
+my $a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ;
+ok(1, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'mpeix') && $? != 0))) ;
+ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/) ;
+
+# no reference parameter in filter_add
+######################################
+
+writeFile("${module}.pm", <<EOM) ;
+package ${module} ;
+
+use Filter::Util::Call ;
+
+sub import { filter_add() }
+
+1 ;
+EOM
+
+$a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ;
+ok(3, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'mpeix') && $? != 0))) ;
+#ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ;
+ok(4, $a =~ /^Not enough arguments for Filter::Util::Call::filter_add/) ;
+
+
+
+
+# non-error cases
+#################
+
+
+# a simple filter, using a closure
+#################
+
+writeFile("${module}.pm", <<EOM, <<'EOM') ;
+package ${module} ;
+
+EOM
+use Filter::Util::Call ;
+sub import {
+ filter_add(
+ sub {
+
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+ } ) ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module ;
+EOM
+
+use Cwd ;
+$here = getcwd ;
+print "I am $here\n" ;
+print "some letters ABC\n" ;
+$y = "ABCDEF" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(5, ($? >>8) == 0) ;
+ok(6, $a eq <<EOM) ;
+I am $here
+some letters DEF
+Alphabetti Spagetti (DEFDEF)
+EOM
+
+# a simple filter, not using a closure
+#################
+
+writeFile("${module}.pm", <<EOM, <<'EOM') ;
+package ${module} ;
+
+EOM
+use Filter::Util::Call ;
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+}
+
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module ;
+EOM
+
+use Cwd ;
+$here = getcwd ;
+print "I am $here\n" ;
+print "some letters ABC\n" ;
+$y = "ABCDEF" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(7, ($? >>8) == 0) ;
+ok(8, $a eq <<EOM) ;
+I am $here
+some letters DEF
+Alphabetti Spagetti (DEFDEF)
+EOM
+
+
+# nested filters
+################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/XYZ/PQR/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile("${module3}.pm", <<EOM, <<'EOM') ;
+package ${module3} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(
+
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/Fred/Joe/g
+ }
+ $status ;
+ } ) ;
+}
+
+1 ;
+EOM
+
+writeFile("${module4}.pm", <<EOM) ;
+package ${module4} ;
+
+use $module5 ;
+
+print "I'm feeling used!\n" ;
+print "Fred Joe ABC DEF PQR XYZ\n" ;
+print "See you Today\n" ;
+1;
+EOM
+
+writeFile("${module5}.pm", <<EOM, <<'EOM') ;
+package ${module5} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/Today/Tomorrow/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+# two filters for this file
+use $module ;
+use $module2 ;
+require "$nested" ;
+use $module4 ;
+EOM
+
+print "some letters ABCXYZ\n" ;
+$y = "ABCDEFXYZ" ;
+print <<EOF ;
+Fred likes Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+writeFile($nested, <<EOM, <<'EOM') ;
+use $module3 ;
+EOM
+
+print "This is another file XYZ\n" ;
+print <<EOF ;
+Where is Fred?
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(9, ($? >>8) == 0) ;
+ok(10, $a eq <<EOM) ;
+I'm feeling used!
+Fred Joe ABC DEF PQR XYZ
+See you Tomorrow
+This is another file XYZ
+Where is Joe?
+some letters DEFPQR
+Fred likes Alphabetti Spagetti (DEFDEFPQR)
+EOM
+
+# using the module context (with a closure)
+###########################################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (
+
+ sub
+ {
+ my ($status) ;
+ my ($pattern) ;
+
+ if (($status = filter_read()) > 0) {
+ foreach $pattern (@strings)
+ { s/$pattern/PQR/g }
+ }
+
+ $status ;
+ }
+ )
+
+}
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 qw( XYZ KLM) ;
+use $module2 qw( ABC NMO) ;
+EOM
+
+print "some letters ABCXYZ KLM NMO\n" ;
+$y = "ABCDEFXYZKLMNMO" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(11, ($? >>8) == 0) ;
+ok(12, $a eq <<EOM) ;
+some letters PQRPQR PQR PQR
+Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+EOM
+
+
+
+# using the module context (without a closure)
+##############################################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (bless [@strings])
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($pattern) ;
+
+ if (($status = filter_read()) > 0) {
+ foreach $pattern (@$self)
+ { s/$pattern/PQR/g }
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 qw( XYZ KLM) ;
+use $module2 qw( ABC NMO) ;
+EOM
+
+print "some letters ABCXYZ KLM NMO\n" ;
+$y = "ABCDEFXYZKLMNMO" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(13, ($? >>8) == 0) ;
+ok(14, $a eq <<EOM) ;
+some letters PQRPQR PQR PQR
+Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+EOM
+
+# multi line test
+#################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add(bless [])
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ # read first line
+ if (($status = filter_read()) > 0) {
+ chop ;
+ s/\r$//;
+ # and now the second line (it will append)
+ $status = filter_read() ;
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 ;
+EOM
+print "don't cut me
+in half\n" ;
+print
+<<EOF ;
+appen
+ded
+EO
+F
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(15, ($? >>8) == 0) ;
+ok(16, $a eq <<EOM) ;
+don't cut me in half
+appended
+EOM
+
+# Block test
+#############
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (bless [@strings] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($pattern) ;
+
+ filter_read(20) ;
+}
+
+1 ;
+EOM
+
+my $string = <<'EOM' ;
+print "hello mum\n" ;
+$x = 'me ' x 3 ;
+print "Who wants it?\n$x\n" ;
+EOM
+
+
+writeFile($filename, <<EOM, $string ) ;
+use $block ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(17, ($? >>8) == 0) ;
+ok(18, $a eq <<EOM) ;
+hello mum
+Who wants it?
+me me me
+EOM
+
+# use in the filter
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+use Cwd ;
+
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add(bless [@strings] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($here) = quotemeta getcwd ;
+
+ if (($status = filter_read()) > 0) {
+ s/DIR/$here/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "We are in DIR\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(19, ($? >>8) == 0) ;
+ok(20, $a eq <<EOM) ;
+We are in $here
+EOM
+
+
+# filter_del
+#############
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+ my ($count) = @_ ;
+
+
+ filter_add(bless \$count )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ s/HERE/THERE/g
+ if ($status = filter_read()) > 0 ;
+
+ -- $$self ;
+ filter_del() if $$self <= 0 ;
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block (3) ;
+EOM
+print "
+HERE I am
+I am HERE
+HERE today gone tomorrow\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(21, ($? >>8) == 0) ;
+ok(22, $a eq <<EOM) ;
+
+THERE I am
+I am THERE
+HERE today gone tomorrow
+EOM
+
+
+# filter_read_exact
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read_exact(9)) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filenamebin, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "
+HERE I am
+I'm HERE
+HERE today gone tomorrow\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filenamebin 2>&1` ;
+ok(23, ($? >>8) == 0) ;
+ok(24, $a eq <<EOM) ;
+
+HERE I am
+I'm THERE
+THERE today gone tomorrow
+EOM
+
+{
+
+# Check __DATA__
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "HERE HERE\n";
+@a = <DATA>;
+print @a;
+__DATA__
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(25, ($? >>8) == 0) ;
+ok(26, $a eq <<EOM) ;
+THERE THERE
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+}
+
+{
+
+# Check __END__
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "HERE HERE\n";
+@a = <DATA>;
+print @a;
+__END__
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(27, ($? >>8) == 0) ;
+ok(28, $a eq <<EOM) ;
+THERE THERE
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+}
+
+END {
+ 1 while unlink $filename ;
+ 1 while unlink $filenamebin ;
+ 1 while unlink "${module}.pm" ;
+ 1 while unlink "${module2}.pm" ;
+ 1 while unlink "${module3}.pm" ;
+ 1 while unlink "${module4}.pm" ;
+ 1 while unlink "${module5}.pm" ;
+ 1 while unlink $nested ;
+ 1 while unlink "${block}.pm" ;
+}
+
+
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/filter-util.pl#1 (text) ====
Index: perl/macos/bundled_ext/Filter/t/filter-util.pl
--- perl/macos/bundled_ext/Filter/t/filter-util.pl.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_ext/Filter/t/filter-util.pl Fri Jul 20 12:30:05 2001
@@ -0,0 +1,54 @@
+
+use strict ;
+use warnings;
+
+use vars qw( $Perl $Inc);
+
+sub readFile
+{
+ my ($filename) = @_ ;
+ my ($string) = '' ;
+
+ open (F, "<$filename")
+ or die "Cannot open $filename: $!\n" ;
+ while (<F>)
+ { $string .= $_ }
+ close F ;
+ $string ;
+}
+
+sub writeFile
+{
+ my($filename, @strings) = @_ ;
+ open (F, ">$filename")
+ or die "Cannot open $filename: $!\n" ;
+ binmode(F) if $filename =~ /bin$/i;
+ foreach (@strings)
+ { print F }
+ close F ;
+}
+
+sub ok
+{
+ my($number, $result, $note) = @_ ;
+
+ $note = "" if ! defined $note ;
+ if ($note) {
+ $note = "# $note" if $note !~ /^\s*#/ ;
+ $note =~ s/^\s*/ / ;
+ }
+
+ print "not " if !$result ;
+ print "ok ${number}${note}\n";
+}
+
+$Inc = '' ;
+foreach (@INC)
+ { $Inc .= "\"-I$_\" " }
+
+$Perl = '' ;
+$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ;
+
+$Perl = "$Perl -w" ;
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Class/ISA.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Class/ISA.pm
--- perl/macos/bundled_lib/blib/lib/Class/ISA.pm.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/blib/lib/Class/ISA.pm Fri Jul 20 12:30:05 2001
@@ -0,0 +1,214 @@
+#!/usr/local/bin/perl
+# Time-stamp: "2000-05-13 20:03:22 MDT" -*-Perl-*-
+
+package Class::ISA;
+require 5;
+use strict;
+use vars qw($Debug $VERSION);
+$VERSION = 0.32;
+$Debug = 0 unless defined $Debug;
+
+=head1 NAME
+
+Class::ISA -- report the search path for a class's ISA tree
+
+=head1 SYNOPSIS
+
+ # Suppose you go: use Food::Fishstick, and that uses and
+ # inherits from other things, which in turn use and inherit
+ # from other things. And suppose, for sake of brevity of
+ # example, that their ISA tree is the same as:
+
+ @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
+ @Food::Fish::ISA = qw(Food);
+ @Food::ISA = qw(Matter);
+ @Life::Fungus::ISA = qw(Life);
+ @Chemicals::ISA = qw(Matter);
+ @Life::ISA = qw(Matter);
+ @Matter::ISA = qw();
+
+ use Class::ISA;
+ print "Food::Fishstick path is:\n ",
+ join(", ", Class::ISA::super_path('Food::Fishstick')),
+ "\n";
+
+That prints:
+
+ Food::Fishstick path is:
+ Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals
+
+=head1 DESCRIPTION
+
+Suppose you have a class (like Food::Fish::Fishstick) that is derived,
+via its @ISA, from one or more superclasses (as Food::Fish::Fishstick
+is from Food::Fish, Life::Fungus, and Chemicals), and some of those
+superclasses may themselves each be derived, via its @ISA, from one or
+more superclasses (as above).
+
+When, then, you call a method in that class ($fishstick->calories),
+Perl first searches there for that method, but if it's not there, it
+goes searching in its superclasses, and so on, in a depth-first (or
+maybe "height-first" is the word) search. In the above example, it'd
+first look in Food::Fish, then Food, then Matter, then Life::Fungus,
+then Life, then Chemicals.
+
+This library, Class::ISA, provides functions that return that list --
+the list (in order) of names of classes Perl would search to find a
+method, with no duplicates.
+
+=head1 FUNCTIONS
+
+=over
+
+=item the function Class::ISA::super_path($CLASS)
+
+This returns the ordered list of names of classes that Perl would
+search thru in order to find a method, with no duplicates in the list.
+$CLASS is not included in the list. UNIVERSAL is not included -- if
+you need to consider it, add it to the end.
+
+
+=item the function Class::ISA::self_and_super_path($CLASS)
+
+Just like C<super_path>, except that $CLASS is included as the first
+element.
+
+=item the function Class::ISA::self_and_super_versions($CLASS)
+
+This returns a hash whose keys are $CLASS and its
+(super-)superclasses, and whose values are the contents of each
+class's $VERSION (or undef, for classes with no $VERSION).
+
+The code for self_and_super_versions is meant to serve as an example
+for precisely the kind of tasks I anticipate that self_and_super_path
+and super_path will be used for. You are strongly advised to read the
+source for self_and_super_versions, and the comments there.
+
+=back
+
+=head1 CAUTIONARY NOTES
+
+* Class::ISA doesn't export anything. You have to address the
+functions with a "Class::ISA::" on the front.
+
+* Contrary to its name, Class::ISA isn't a class; it's just a package.
+Strange, isn't it?
+
+* Say you have a loop in the ISA tree of the class you're calling one
+of the Class::ISA functions on: say that Food inherits from Matter,
+but Matter inherits from Food (for sake of argument). If Perl, while
+searching for a method, actually discovers this cyclicity, it will
+throw a fatal error. The functions in Class::ISA effectively ignore
+this cyclicity; the Class::ISA algorithm is "never go down the same
+path twice", and cyclicities are just a special case of that.
+
+* The Class::ISA functions just look at @ISAs. But theoretically, I
+suppose, AUTOLOADs could bypass Perl's ISA-based search mechanism and
+do whatever they please. That would be bad behavior, tho; and I try
+not to think about that.
+
+* If Perl can't find a method anywhere in the ISA tree, it then looks
+in the magical class UNIVERSAL. This is rarely relevant to the tasks
+that I expect Class::ISA functions to be put to, but if it matters to
+you, then instead of this:
+
+ @supers = Class::Tree::super_path($class);
+
+do this:
+
+ @supers = (Class::Tree::super_path($class), 'UNIVERSAL');
+
+And don't say no-one ever told ya!
+
+* When you call them, the Class::ISA functions look at @ISAs anew --
+that is, there is no memoization, and so if ISAs change during
+runtime, you get the current ISA tree's path, not anything memoized.
+However, changing ISAs at runtime is probably a sign that you're out
+of your mind!
+
+=head1 COPYRIGHT
+
+Copyright (c) 1999, 2000 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Sean M. Burke C<[email protected]>
+
+=cut
+
+###########################################################################
+
+sub self_and_super_versions {
+ no strict 'refs';
+ map {
+ $_ => (defined(${"$_\::VERSION"}) ? ${"$_\::VERSION"} : undef)
+ } self_and_super_path($_[0])
+}
+
+# Also consider magic like:
+# no strict 'refs';
+# my %class2SomeHashr =
+# map { defined(%{"$_\::SomeHash"}) ? ($_ => \%{"$_\::SomeHash"}) : () }
+# Class::ISA::self_and_super_path($class);
+# to get a hash of refs to all the defined (and non-empty) hashes in
+# $class and its superclasses.
+#
+# Or even consider this incantation for doing something like hash-data
+# inheritance:
+# no strict 'refs';
+# %union_hash =
+# map { defined(%{"$_\::SomeHash"}) ? %{"$_\::SomeHash"}) : () }
+# reverse(Class::ISA::self_and_super_path($class));
+# Consider that reverse() is necessary because with
+# %foo = ('a', 'wun', 'b', 'tiw', 'a', 'foist');
+# $foo{'a'} is 'foist', not 'wun'.
+
+###########################################################################
+sub super_path {
+ my @ret = &self_and_super_path(@_);
+ shift @ret if @ret;
+ return @ret;
+}
+
+#--------------------------------------------------------------------------
+sub self_and_super_path {
+ # Assumption: searching is depth-first.
+ # Assumption: '' (empty string) can't be a class package name.
+ # Note: 'UNIVERSAL' is not given any special treatment.
+ return () unless @_;
+
+ my @out = ();
+
+ my @in_stack = ($_[0]);
+ my %seen = ($_[0] => 1);
+
+ my $current;
+ while(@in_stack) {
+ next unless defined($current = shift @in_stack) && length($current);
+ print "At $current\n" if $Debug;
+ push @out, $current;
+ no strict 'refs';
+ unshift @in_stack,
+ map
+ { my $c = $_; # copy, to avoid being destructive
+ substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
+ # Canonize the :: -> main::, ::foo -> main::foo thing.
+ # Should I ever canonize the Foo'Bar = Foo::Bar thing?
+ $seen{$c}++ ? () : $c;
+ }
+ @{"$current\::ISA"}
+ ;
+ # I.e., if this class has any parents (at least, ones I've never seen
+ # before), push them, in order, onto the stack of classes I need to
+ # explore.
+ }
+
+ return @out;
+}
+#--------------------------------------------------------------------------
+1;
+
+__END__
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Digest.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Digest.pm
--- perl/macos/bundled_lib/blib/lib/Digest.pm.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/blib/lib/Digest.pm Fri Jul 20 12:30:05 2001
@@ -0,0 +1,180 @@
+package Digest;
+
+use strict;
+use vars qw($VERSION %MMAP $AUTOLOAD);
+
+$VERSION = "1.00";
+
+%MMAP = (
+ "SHA-1" => "Digest::SHA1",
+ "HMAC-MD5" => "Digest::HMAC_MD5",
+ "HMAC-SHA-1" => "Digest::HMAC_SHA1",
+);
+
+sub new
+{
+ shift; # class ignored
+ my $algorithm = shift;
+ my $class = $MMAP{$algorithm} || "Digest::$algorithm";
+ no strict 'refs';
+ unless (exists ${"$class\::"}{"VERSION"}) {
+ eval "require $class";
+ die $@ if $@;
+ }
+ $class->new(@_);
+}
+
+sub AUTOLOAD
+{
+ my $class = shift;
+ my $algorithm = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+ $class->new($algorithm, @_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest:: - Modules that calculate message digests
+
+=head1 SYNOPSIS
+
+ $md2 = Digest->MD2;
+ $md5 = Digest->MD5;
+
+ $sha1 = Digest->SHA1;
+ $sha1 = Digest->new("SHA-1");
+
+ $hmac = Digest->HMAC_MD5($key);
+
+=head1 DESCRIPTION
+
+The C<Digest::> modules calculate digests, also called "fingerprints"
+or "hashes", of some data, called a message. The digest is (usually)
+some small/fixed size string. The actual size of the digest depend of
+the algorithm used. The message is simply a sequence of arbitrary
+bytes.
+
+An important property of the digest algorithms is that the digest is
+I<likely> to change if the message change in some way. Another
+property is that digest functions are one-way functions, i.e. it
+should be I<hard> to find a message that correspond to some given
+digest. Algorithms differ in how "likely" and how "hard", as well as
+how efficient they are to compute.
+
+All C<Digest::> modules provide the same programming interface. A
+functional interface for simple use, as well as an object oriented
+interface that can handle messages of arbitrary length and which can
+read files directly.
+
+The digest can be delivered in three formats:
+
+=over 8
+
+=item I<binary>
+
+This is the most compact form, but it is not well suited for printing
+or embedding in places that can't handle arbitrary data.
+
+=item I<hex>
+
+A twice as long string of (lowercase) hexadecimal digits.
+
+=item I<base64>
+
+A string of portable printable characters. This is the base64 encoded
+representation of the digest with any trailing padding removed. The
+string will be about 30% longer than the binary version.
+L<MIME::Base64> tells you more about this encoding.
+
+=back
+
+
+The functional interface is simply importable functions with the same
+name as the algorithm. The functions take the message as argument and
+return the digest. Example:
+
+ use Digest::MD5 qw(md5);
+ $digest = md5($message);
+
+There are also versions of the functions with "_hex" or "_base64"
+appended to the name, which returns the digest in the indicated form.
+
+=head1 OO INTERFACE
+
+The following methods are available for all C<Digest::> modules:
+
+=over 4
+
+=item $ctx = Digest->XXX($arg,...)
+
+=item $ctx = Digest->new(XXX => $arg,...)
+
+=item $ctx = Digest::XXX->new($arg,...)
+
+The constructor returns some object that encapsulate the state of the
+message-digest algorithm. You can add data to the object and finally
+ask for the digest. The "XXX" should of course be replaced by the proper
+name of the digest algorithm you want to use.
+
+The two first forms are simply syntactic sugar which automatically
+load the right module on first use. The second form allow you to use
+algorithm names which contains letters which are not legal perl
+identifiers, e.g. "SHA-1".
+
+If new() is called as a instance method (i.e. $ctx->new) it will just
+reset the state the object to the state of a newly created object. No
+new object is created in this case, and the return value is the
+reference to the object (i.e. $ctx).
+
+=item $ctx->reset
+
+This is just an alias for $ctx->new.
+
+=item $ctx->add($data,...)
+
+The $data provided as argument are appended to the message we
+calculate the digest for. The return value is the $ctx object itself.
+
+=item $ctx->addfile($io_handle)
+
+The $io_handle is read until EOF and the content is appended to the
+message we calculate the digest for. The return value is the $ctx
+object itself.
+
+=item $ctx->digest
+
+Return the binary digest for the message.
+
+Note that the C<digest> operation is effectively a destructive,
+read-once operation. Once it has been performed, the $ctx object is
+automatically C<reset> and can be used to calculate another digest
+value.
+
+=item $ctx->hexdigest
+
+Same as $ctx->digest, but will return the digest in hexadecimal form.
+
+=item $ctx->b64digest
+
+Same as $ctx->digest, but will return the digest as a base64 encoded
+string.
+
+=back
+
+=head1 SEE ALSO
+
+L<Digest::MD5>, L<Digest::SHA1>, L<Digest::HMAC>, L<Digest::MD2>
+
+L<MIME::Base64>
+
+=head1 AUTHOR
+
+Gisle Aas <[email protected]>
+
+The C<Digest::> interface is based on the interface originally
+developed by Neil Winton for his C<MD5> module.
+
+=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Filter/Simple.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Filter/Simple.pm
--- perl/macos/bundled_lib/blib/lib/Filter/Simple.pm.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/blib/lib/Filter/Simple.pm Fri Jul 20 12:30:05 2001
@@ -0,0 +1,344 @@
+package Filter::Simple;
+
+use vars qw{ $VERSION };
+
+$VERSION = '0.60';
+
+use Filter::Util::Call;
+use Carp;
+
+sub import {
+ if (@_>1) { shift; goto &FILTER }
+ else { *{caller()."::FILTER"} = \&FILTER }
+}
+
+sub FILTER (&;$) {
+ my $caller = caller;
+ my ($filter, $terminator) = @_;
+ croak "Usage: use Filter::Simple sub {...}, $terminator_opt;"
+ unless ref $filter eq CODE;
+ *{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator);
+ *{"${caller}::unimport"} = \*filter_unimport;
+}
+
+sub gen_filter_import {
+ my ($class, $filter, $terminator) = @_;
+ return sub {
+ my ($imported_class, @args) = @_;
+ $terminator = qr/^\s*no\s+$imported_class\s*;\s*$/
+ unless defined $terminator;
+ filter_add(
+ sub {
+ my ($status, $off);
+ my $count = 0;
+ my $data = "";
+ while ($status = filter_read()) {
+ return $status if $status < 0;
+ if ($terminator && m/$terminator/) {
+ $off=1;
+ last;
+ }
+ $data .= $_;
+ $count++;
+ $_ = "";
+ }
+ $_ = $data;
+ $filter->(@args) unless $status < 0;
+ $_ .= "no $imported_class;\n" if $off;
+ return $count;
+ }
+ );
+ }
+}
+
+sub filter_unimport {
+ filter_del();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Filter::Simple - Simplified source filtering
+
+
+=head1 SYNOPSIS
+
+ # in MyFilter.pm:
+
+ package MyFilter;
+
+ use Filter::Simple;
+
+ FILTER { ... };
+
+ # or just:
+ #
+ # use Filter::Simple sub { ... };
+
+ # in user's code:
+
+ use MyFilter;
+
+ # this code is filtered
+
+ no MyFilter;
+
+ # this code is not
+
+
+=head1 DESCRIPTION
+
+=head2 The Problem
+
+Source filtering is an immensely powerful feature of recent versions of Perl.
+It allows one to extend the language itself (e.g. the Switch module), to
+simplify the language (e.g. Language::Pythonesque), or to completely recast the
+language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use
+the full power of Perl as its own, recursively applied, macro language.
+
+The excellent Filter::Util::Call module (by Paul Marquess) provides a
+usable Perl interface to source filtering, but it is often too powerful
+and not nearly as simple as it could be.
+
+To use the module it is necessary to do the following:
+
+=over 4
+
+=item 1.
+
+Download, build, and install the Filter::Util::Call module.
+(If you have Perl 5.7.1 or later you already have Filter::Util::Call.)
+
+=item 2.
+
+Set up a module that does a C<use Filter::Util::Call>.
+
+=item 3.
+
+Within that module, create an C<import> subroutine.
+
+=item 4.
+
+Within the C<import> subroutine do a call to C<filter_add>, passing
+it either a subroutine reference.
+
+=item 5.
+
+Within the subroutine reference, call C<filter_read> or C<filter_read_exact>
+to "prime" $_ with source code data from the source file that will
+C<use> your module. Check the status value returned to see if any
+source code was actually read in.
+
+=item 6.
+
+Process the contents of $_ to change the source code in the desired manner.
+
+=item 7.
+
+Return the status value.
+
+=item 8.
+
+If the act of unimporting your module (via a C<no>) should cause source
+code filtering to cease, create an C<unimport> subroutine, and have it call
+C<filter_del>. Make sure that the call to C<filter_read> or
+C<filter_read_exact> in step 5 will not accidentally read past the
+C<no>. Effectively this limits source code filters to line-by-line
+operation, unless the C<import> subroutine does some fancy
+pre-pre-parsing of the source code it's filtering.
+
+=back
+
+For example, here is a minimal source code filter in a module named
+BANG.pm. It simply converts every occurrence of the sequence C<BANG\s+BANG>
+to the sequence C<die 'BANG' if $BANG> in any piece of code following a
+C<use BANG;> statement (until the next C<no BANG;> statement, if any):
+
+ package BANG;
+
+ use Filter::Util::Call ;
+
+ sub import {
+ filter_add( sub {
+ my $caller = caller;
+ my ($status, $no_seen, $data);
+ while ($status = filter_read()) {
+ if (/^\s*no\s+$caller\s*;\s*?$/) {
+ $no_seen=1;
+ last;
+ }
+ $data .= $_;
+ $_ = "";
+ }
+ $_ = $data;
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g
+ unless $status < 0;
+ $_ .= "no $class;\n" if $no_seen;
+ return 1;
+ })
+ }
+
+ sub unimport {
+ filter_del();
+ }
+
+ 1 ;
+
+This level of sophistication puts filtering out of the reach of
+many programmers.
+
+
+=head2 A Solution
+
+The Filter::Simple module provides a simplified interface to
+Filter::Util::Call; one that is sufficient for most common cases.
+
+Instead of the above process, with Filter::Simple the task of setting up
+a source code filter is reduced to:
+
+=over 4
+
+=item 1.
+
+Set up a module that does a C<use Filter::Simple> and then
+calls C<FILTER { ... }>.
+
+=item 2.
+
+Within the anonymous subroutine or block that is passed to
+C<FILTER>, process the contents of $_ to change the source code in
+the desired manner.
+
+=back
+
+In other words, the previous example, would become:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+
+ 1 ;
+
+
+=head2 Disabling or changing <no> behaviour
+
+By default, the installed filter only filters to a line of the form:
+
+ no ModuleName;
+
+but this can be altered by passing a second argument to C<use Filter::Simple>.
+
+That second argument may be either a C<qr>'d regular expression (which is then
+used to match the terminator line), or a defined false value (which indicates
+that no terminator line should be looked for).
+
+For example, to cause the previous filter to filter only up to a line of the
+form:
+
+ GNAB esu;
+
+you would write:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ => qr/^\s*GNAB\s+esu\s*;\s*?$/;
+
+and to prevent the filter's being turned off in any way:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ => "";
+ # or: => 0;
+
+
+=head2 All-in-one interface
+
+Separating the loading of Filter::Simple:
+
+ use Filter::Simple;
+
+from the setting up of the filtering:
+
+ FILTER { ... };
+
+is useful because it allows other code (typically parser support code
+or caching variables) to be defined before the filter is invoked.
+However, there is often no need for such a separation.
+
+In those cases, it is easier to just append the filtering subroutine and
+any terminator specification directly to the C<use> statement that loads
+Filter::Simple, like so:
+
+ use Filter::Simple sub {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+
+This is exactly the same as:
+
+ use Filter::Simple;
+ BEGIN {
+ Filter::Simple::FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+ }
+
+except that the C<FILTER> subroutine is not exported by Filter::Simple.
+
+
+=head2 How it works
+
+The Filter::Simple module exports into the package that calls C<FILTER>
+(or C<use>s it directly) -- such as package "BANG" in the above example --
+two automagically constructed
+subroutines -- C<import> and C<unimport> -- which take care of all the
+nasty details.
+
+In addition, the generated C<import> subroutine passes its own argument
+list to the filtering subroutine, so the BANG.pm filter could easily
+be made parametric:
+
+ package BANG;
+
+ use Filter::Simple;
+
+ FILTER {
+ my ($die_msg, $var_name) = @_;
+ s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
+ };
+
+ # and in some user code:
+
+ use BANG "BOOM", "BAM"; # "BANG BANG" becomes: die 'BOOM' if $BAM
+
+
+The specified filtering subroutine is called every time a C<use BANG> is
+encountered, and passed all the source code following that call, up to
+either the next C<no BANG;> (or whatever terminator you've set) or the
+end of the source file, whichever occurs first. By default, any C<no
+BANG;> call must appear by itself on a separate line, or it is ignored.
+
+
+=head1 AUTHOR
+
+Damian Conway ([email protected])
+
+=head1 COPYRIGHT
+
+ Copyright (c) 2000, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+and/or modified under the terms of the Perl Artistic License
+ (see http://www.perl.com/perl/misc/Artistic.html)
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Switch.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Switch.pm
--- perl/macos/bundled_lib/blib/lib/Switch.pm.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/blib/lib/Switch.pm Fri Jul 20 12:30:05 2001
@@ -0,0 +1,786 @@
+package Switch;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = '2.03';
+
+
+# LOAD FILTERING MODULE...
+use Filter::Util::Call;
+
+sub __();
+
+# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
+
+$::_S_W_I_T_C_H = sub { croak "case statement not in switch block" };
+
+my $offset;
+my $fallthrough;
+
+sub import
+{
+ $DB::single = 1;
+ $fallthrough = grep /\bfallthrough\b/, @_;
+ $offset = (caller)[2]+1;
+ filter_add({}) unless @_>1 && $_[1] eq 'noimport';
+ my $pkg = caller;
+ no strict 'refs';
+ for ( qw( on_defined on_exists ) )
+ {
+ *{"${pkg}::$_"} = \&$_;
+ }
+ *{"${pkg}::__"} = \&__ if grep /__/, @_;
+ 1;
+}
+
+sub unimport
+{
+ filter_del()
+}
+
+sub filter
+{
+ my($self) = @_ ;
+ local $Switch::file = (caller)[1];
+
+ my $status = 1;
+ $status = filter_read(10_000);
+ return $status if $status<0;
+ $_ = filter_blocks($_,$offset);
+ $_ = "# line $offset\n" . $_ if $offset; undef $offset;
+ # print STDERR $_;
+ return $status;
+}
+
+use Text::Balanced ':ALL';
+
+sub line
+{
+ my ($pretext,$offset) = @_;
+ ($pretext=~tr/\n/\n/)+$offset,
+}
+
+sub is_block
+{
+ local $SIG{__WARN__}=sub{die$@};
+ local $^W=1;
+ my $ishash = defined eval 'my $hr='.$_[0];
+ undef $@;
+ return !$ishash;
+}
+
+my $casecounter = 1;
+sub filter_blocks
+{
+ my ($source, $line) = @_;
+ return $source unless $source =~ /case|switch/;
+ pos $source = 0;
+ my $text = "";
+ component: while (pos $source < length $source)
+ {
+ if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
+ {
+ $text .= q{use Switch 'noimport'};
+ next component;
+ }
+ my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
+ if (defined $pos[0])
+ {
+ $text .= " " . substr($source,$pos[2],$pos[18]-$pos[2]);
+ next component;
+ }
+ @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
+ if (defined $pos[0])
+ {
+ $text .= " " . substr($source,$pos[0],$pos[4]-$pos[0]);
+ next component;
+ }
+
+ if ($source =~ m/\G(\n*)(\s*)switch\b(?=\s*[(])/gc)
+ {
+ $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
+ @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
+ or do {
+ die "Bad switch statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+ };
+ my $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
+ $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
+ $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
+ $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
+ @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
+ or do {
+ die "Bad switch statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
+ };
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
+ $text .= $code . 'continue {last}';
+ next component;
+ }
+ elsif ($source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc)
+ {
+ $text .= $1."if (Switch::case";
+ if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
+ my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
+ $text .= " sub" if is_block $code;
+ $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
+ }
+ elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
+ $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
+ $code =~ s {^\s*[(]\s*/} { ( qr/} ||
+ $code =~ s {^\s*[(]\s*qw} { ( \\qw};
+ $text .= " $code)";
+ }
+ elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1)) {
+ my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
+ $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
+ $code =~ s {^\s*m} { qr} ||
+ $code =~ s {^\s*/} { qr/} ||
+ $code =~ s {^\s*qw} { \\qw};
+ $text .= " $code)";
+ }
+ elsif ($source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc) {
+ my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
+ $text .= ' \\' if $2 eq '%';
+ $text .= " $code)";
+ }
+ else {
+ die "Bad case statement (invalid case value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
+ }
+
+ @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
+ or do {
+ if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
+ $casecounter++;
+ next component;
+ }
+ die "Bad case statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+ };
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
+ unless $fallthrough;
+ $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
+ $casecounter++;
+ next component;
+ }
+
+ $source =~ m/\G(\s*(\w+|#.*\n|\W))/gc;
+ $text .= $1;
+ }
+ $text;
+}
+
+
+
+sub in
+{
+ my ($x,$y) = @_;
+ my @numy;
+ for my $nextx ( @$x )
+ {
+ my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
+ for my $j ( 0..$#$y )
+ {
+ my $nexty = $y->[$j];
+ push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
+ if @numy <= $j;
+ return 1 if $numx && $numy[$j] && $nextx==$nexty
+ || $nextx eq $nexty;
+
+ }
+ }
+ return "";
+}
+
+sub on_exists
+{
+ my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
+ [ keys %$ref ]
+}
+
+sub on_defined
+{
+ my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
+ [ grep { defined $ref->{$_} } keys %$ref ]
+}
+
+sub switch(;$)
+{
+ my ($s_val) = @_ ? $_[0] : $_;
+ my $s_ref = ref $s_val;
+
+ if ($s_ref eq 'CODE')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ return $s_val == $c_val if ref $c_val eq 'CODE';
+ return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
+ return $s_val->($c_val);
+ };
+ }
+ elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val == $c_val if $c_ref eq ""
+ && defined $c_val
+ && (~$c_val&$c_val) eq 0;
+ return $s_val eq $c_val if $c_ref eq "";
+ return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return scalar $s_val=~/$c_val/
+ if $c_ref eq 'Regexp';
+ return scalar $c_val->{$s_val}
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq "") # STRING SCALAR
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val eq $c_val if $c_ref eq "";
+ return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return scalar $s_val=~/$c_val/
+ if $c_ref eq 'Regexp';
+ return scalar $c_val->{$s_val}
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'ARRAY')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return in($s_val,[$c_val]) if $c_ref eq "";
+ return in($s_val,$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->(@$s_val) if $c_ref eq 'CODE';
+ return $c_val->call(@$s_val)
+ if $c_ref eq 'Switch';
+ return scalar grep {$_=~/$c_val/} @$s_val
+ if $c_ref eq 'Regexp';
+ return scalar grep {$c_val->{$_}} @$s_val
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'Regexp')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $c_val=~/s_val/ if $c_ref eq "";
+ return scalar grep {$_=~/s_val/} @$c_val
+ if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return $s_val eq $c_val if $c_ref eq 'Regexp';
+ return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'HASH')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val->{$c_val} if $c_ref eq "";
+ return scalar grep {$s_val->{$_}} @$c_val
+ if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
+ if $c_ref eq 'Regexp';
+ return $s_val==$c_val if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'Switch')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ return $s_val == $c_val if ref $c_val eq 'Switch';
+ return $s_val->call(@$c_val)
+ if ref $c_val eq 'ARRAY';
+ return $s_val->call($c_val);
+ };
+ }
+ else
+ {
+ croak "Cannot switch on $s_ref";
+ }
+ return 1;
+}
+
+sub case($) { $::_S_W_I_T_C_H->(@_); }
+
+# IMPLEMENT __
+
+my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
+
+sub __() { $placeholder }
+
+sub __arg($)
+{
+ my $index = $_[0]+1;
+ bless { arity=>0, impl=>sub{$_[$index]} };
+}
+
+sub hosub(&@)
+{
+ # WRITE THIS
+}
+
+sub call
+{
+ my ($self,@args) = @_;
+ return $self->{impl}->(0,@args);
+}
+
+sub meta_bop(&)
+{
+ my ($op) = @_;
+ sub
+ {
+ my ($left, $right, $reversed) = @_;
+ ($right,$left) = @_ if $reversed;
+
+ my $rop = ref $right eq 'Switch'
+ ? $right
+ : bless { arity=>0, impl=>sub{$right} };
+
+ my $lop = ref $left eq 'Switch'
+ ? $left
+ : bless { arity=>0, impl=>sub{$left} };
+
+ my $arity = $lop->{arity} + $rop->{arity};
+
+ return bless {
+ arity => $arity,
+ impl => sub { my $start = shift;
+ return $op->($lop->{impl}->($start,@_),
+ $rop->{impl}->($start+$lop->{arity},@_));
+ }
+ };
+ };
+}
+
+sub meta_uop(&)
+{
+ my ($op) = @_;
+ sub
+ {
+ my ($left) = @_;
+
+ my $lop = ref $left eq 'Switch'
+ ? $left
+ : bless { arity=>0, impl=>sub{$left} };
+
+ my $arity = $lop->{arity};
+
+ return bless {
+ arity => $arity,
+ impl => sub { $op->($lop->{impl}->(@_)) }
+ };
+ };
+}
+
+
+use overload
+ "+" => meta_bop {$_[0] + $_[1]},
+ "-" => meta_bop {$_[0] - $_[1]},
+ "*" => meta_bop {$_[0] * $_[1]},
+ "/" => meta_bop {$_[0] / $_[1]},
+ "%" => meta_bop {$_[0] % $_[1]},
+ "**" => meta_bop {$_[0] ** $_[1]},
+ "<<" => meta_bop {$_[0] << $_[1]},
+ ">>" => meta_bop {$_[0] >> $_[1]},
+ "x" => meta_bop {$_[0] x $_[1]},
+ "." => meta_bop {$_[0] . $_[1]},
+ "<" => meta_bop {$_[0] < $_[1]},
+ "<=" => meta_bop {$_[0] <= $_[1]},
+ ">" => meta_bop {$_[0] > $_[1]},
+ ">=" => meta_bop {$_[0] >= $_[1]},
+ "==" => meta_bop {$_[0] == $_[1]},
+ "!=" => meta_bop {$_[0] != $_[1]},
+ "<=>" => meta_bop {$_[0] <=> $_[1]},
+ "lt" => meta_bop {$_[0] lt $_[1]},
+ "le" => meta_bop {$_[0] le $_[1]},
+ "gt" => meta_bop {$_[0] gt $_[1]},
+ "ge" => meta_bop {$_[0] ge $_[1]},
+ "eq" => meta_bop {$_[0] eq $_[1]},
+ "ne" => meta_bop {$_[0] ne $_[1]},
+ "cmp" => meta_bop {$_[0] cmp $_[1]},
+ "\&" => meta_bop {$_[0] & $_[1]},
+ "^" => meta_bop {$_[0] ^ $_[1]},
+ "|" => meta_bop {$_[0] | $_[1]},
+ "atan2" => meta_bop {atan2 $_[0], $_[1]},
+
+ "neg" => meta_uop {-$_[0]},
+ "!" => meta_uop {!$_[0]},
+ "~" => meta_uop {~$_[0]},
+ "cos" => meta_uop {cos $_[0]},
+ "sin" => meta_uop {sin $_[0]},
+ "exp" => meta_uop {exp $_[0]},
+ "abs" => meta_uop {abs $_[0]},
+ "log" => meta_uop {log $_[0]},
+ "sqrt" => meta_uop {sqrt $_[0]},
+ "bool" => sub { croak "Can't use && or || in expression containing __" },
+
+ # "&()" => sub { $_[0]->{impl} },
+
+ # "||" => meta_bop {$_[0] || $_[1]},
+ # "&&" => meta_bop {$_[0] && $_[1]},
+ # fallback => 1,
+ ;
+1;
+
+__END__
+
+
+=head1 NAME
+
+Switch - A switch statement for Perl
+
+=head1 VERSION
+
+This document describes version 2.03 of Switch,
+released May 15, 2001.
+
+=head1 SYNOPSIS
+
+ use Switch;
+
+ switch ($val) {
+
+ case 1 { print "number 1" }
+ case "a" { print "string a" }
+ case [1..10,42] { print "number in list" }
+ case (@array) { print "number in list" }
+ case /\w+/ { print "pattern" }
+ case qr/\w+/ { print "pattern" }
+ case (%hash) { print "entry in hash" }
+ case (\%hash) { print "entry in hash" }
+ case (\&sub) { print "arg to subroutine" }
+ else { print "previous case not true" }
+ }
+
+=head1 BACKGROUND
+
+[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
+and wherefores of this control structure]
+
+In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
+it is useful to generalize this notion of distributed conditional
+testing as far as possible. Specifically, the concept of "matching"
+between the switch value and the various case values need not be
+restricted to numeric (or string or referential) equality, as it is in other
+languages. Indeed, as Table 1 illustrates, Perl
+offers at least eighteen different ways in which two values could
+generate a match.
+
+ Table 1: Matching a switch value ($s) with a case value ($c)
+
+ Switch Case Type of Match Implied Matching Code
+ Value Value
+ ====== ===== ===================== =============
+
+ number same numeric or referential match if $s == $c;
+ or ref equality
+
+ object method result of method call match if $s->$c();
+ ref name match if defined $s->$c();
+ or ref
+
+ other other string equality match if $s eq $c;
+ non-ref non-ref
+ scalar scalar
+
+ string regexp pattern match match if $s =~ /$c/;
+
+ array scalar array entry existence match if 0<=$c && $c<@$s;
+ ref array entry definition match if defined $s->[$c];
+ array entry truth match if $s->[$c];
+
+ array array array intersection match if intersects(@$s, @$c);
+ ref ref (apply this table to
+ all pairs of elements
+ $s->[$i] and
+ $c->[$j])
+
+ array regexp array grep match if grep /$c/, @$s;
+ ref
+
+ hash scalar hash entry existence match if exists $s->{$c};
+ ref hash entry definition match if defined $s->{$c};
+ hash entry truth match if $s->{$c};
+
+ hash regexp hash grep match if grep /$c/, keys %$s;
+ ref
+
+ sub scalar return value defn match if defined $s->($c);
+ ref return value truth match if $s->($c);
+
+ sub array return value defn match if defined $s->(@$c);
+ ref ref return value truth match if $s->(@$c);
+
+
+In reality, Table 1 covers 31 alternatives, because only the equality and
+intersection tests are commutative; in all other cases, the roles of
+the C<$s> and C<$c> variables could be reversed to produce a
+different test. For example, instead of testing a single hash for
+the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
+one could test for the existence of a single key in a series of hashes
+(C<match if exists $c-E<gt>{$s}>).
+
+As L<perltodo> observes, a Perl case mechanism must support all these
+"ways to do it".
+
+
+=head1 DESCRIPTION
+
+The Switch.pm module implements a generalized case mechanism that covers
+the numerous possible combinations of switch and case values described above.
+
+The module augments the standard Perl syntax with two new control
+statements: C<switch> and C<case>. The C<switch> statement takes a
+single scalar argument of any type, specified in parentheses.
+C<switch> stores this value as the
+current switch value in a (localized) control variable.
+The value is followed by a block which may contain one or more
+Perl statements (including the C<case> statement described below).
+The block is unconditionally executed once the switch value has
+been cached.
+
+A C<case> statement takes a single scalar argument (in mandatory
+parentheses if it's a variable; otherwise the parens are optional) and
+selects the appropriate type of matching between that argument and the
+current switch value. The type of matching used is determined by the
+respective types of the switch value and the C<case> argument, as
+specified in Table 1. If the match is successful, the mandatory
+block associated with the C<case> statement is executed.
+
+In most other respects, the C<case> statement is semantically identical
+to an C<if> statement. For example, it can be followed by an C<else>
+clause, and can be used as a postfix statement qualifier.
+
+However, when a C<case> block has been executed control is automatically
+transferred to the statement after the immediately enclosing C<switch>
+block, rather than to the next statement within the block. In other
+words, the success of any C<case> statement prevents other cases in the
+same scope from executing. But see L<"Allowing fall-through"> below.
+
+Together these two new statements provide a fully generalized case
+mechanism:
+
+ use Switch;
+
+ # AND LATER...
+
+ %special = ( woohoo => 1, d'oh => 1 );
+
+ while (<>) {
+ switch ($_) {
+
+ case %special { print "homer\n"; } # if $special{$_}
+ case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
+ case [1..9] { print "small num\n"; } # if $_ in [1..9]
+
+ case { $_[0] >= 10 } { # if $_ >= 10
+ my $age = <>;
+ switch (sub{ $_[0] < $age } ) {
+
+ case 20 { print "teens\n"; } # if 20 < $age
+ case 30 { print "twenties\n"; } # if 30 < $age
+ else { print "history\n"; }
+ }
+ }
+
+ print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
+ }
+
+Note that C<switch>es can be nested within C<case> (or any other) blocks,
+and a series of C<case> statements can try different types of matches
+-- hash membership, pattern match, array intersection, simple equality,
+etc. -- against the same switch value.
+
+The use of intersection tests against an array reference is particularly
+useful for aggregating integral cases:
+
+ sub classify_digit
+ {
+ switch ($_[0]) { case 0 { return 'zero' }
+ case [2,4,6,8] { return 'even' }
+ case [1,3,4,7,9] { return 'odd' }
+ case /[A-F]/i { return 'hex' }
+ }
+ }
+
+
+=head2 Allowing fall-through
+
+Fall-though (trying another case after one has already succeeded)
+is usually a Bad Idea in a switch statement. However, this
+is Perl, not a police state, so there I<is> a way to do it, if you must.
+
+If a C<case> block executes an untargetted C<next>, control is
+immediately transferred to the statement I<after> the C<case> statement
+(i.e. usually another case), rather than out of the surrounding
+C<switch> block.
+
+For example:
+
+ switch ($val) {
+ case 1 { handle_num_1(); next } # and try next case...
+ case "1" { handle_str_1(); next } # and try next case...
+ case [0..9] { handle_num_any(); } # and we're done
+ case /\d/ { handle_dig_any(); next } # and try next case...
+ case /.*/ { handle_str_any(); next } # and try next case...
+ }
+
+If $val held the number C<1>, the above C<switch> block would call the
+first three C<handle_...> subroutines, jumping to the next case test
+each time it encountered a C<next>. After the thrid C<case> block
+was executed, control would jump to the end of the enclosing
+C<switch> block.
+
+On the other hand, if $val held C<10>, then only the last two C<handle_...>
+subroutines would be called.
+
+Note that this mechanism allows the notion of I<conditional fall-through>.
+For example:
+
+ switch ($val) {
+ case [0..9] { handle_num_any(); next if $val < 7; }
+ case /\d/ { handle_dig_any(); }
+ }
+
+If an untargetted C<last> statement is executed in a case block, this
+immediately transfers control out of the enclosing C<switch> block
+(in other words, there is an implicit C<last> at the end of each
+normal C<case> block). Thus the previous example could also have been
+written:
+
+ switch ($val) {
+ case [0..9] { handle_num_any(); last if $val >= 7; next; }
+ case /\d/ { handle_dig_any(); }
+ }
+
+
+=head2 Automating fall-through
+
+In situations where case fall-through should be the norm, rather than an
+exception, an endless succession of terminal C<next>s is tedious and ugly.
+Hence, it is possible to reverse the default behaviour by specifying
+the string "fallthrough" when importing the module. For example, the
+following code is equivalent to the first example in L<"Allowing fall-through">:
+
+ use Switch 'fallthrough';
+
+ switch ($val) {
+ case 1 { handle_num_1(); }
+ case "1" { handle_str_1(); }
+ case [0..9] { handle_num_any(); last }
+ case /\d/ { handle_dig_any(); }
+ case /.*/ { handle_str_any(); }
+ }
+
+Note the explicit use of a C<last> to preserve the non-fall-through
+behaviour of the third case.
+
+
+
+=head2 Higher-order Operations
+
+One situation in which C<switch> and C<case> do not provide a good
+substitute for a cascaded C<if>, is where a switch value needs to
+be tested against a series of conditions. For example:
+
+ sub beverage {
+ switch (shift) {
+
+ case sub { $_[0] < 10 } { return 'milk' }
+ case sub { $_[0] < 20 } { return 'coke' }
+ case sub { $_[0] < 30 } { return 'beer' }
+ case sub { $_[0] < 40 } { return 'wine' }
+ case sub { $_[0] < 50 } { return 'malt' }
+ case sub { $_[0] < 60 } { return 'Moet' }
+ else { return 'milk' }
+ }
+ }
+
+The need to specify each condition as a subroutine block is tiresome. To
+overcome this, when importing Switch.pm, a special "placeholder"
+subroutine named C<__> [sic] may also be imported. This subroutine
+converts (almost) any expression in which it appears to a reference to a
+higher-order function. That is, the expression:
+
+ use Switch '__';
+
+ __ < 2 + __
+
+is equivalent to:
+
+ sub { $_[0] < 2 + $_[1] }
+
+With C<__>, the previous ugly case statements can be rewritten:
+
+ case __ < 10 { return 'milk' }
+ case __ < 20 { return 'coke' }
+ case __ < 30 { return 'beer' }
+ case __ < 40 { return 'wine' }
+ case __ < 50 { return 'malt' }
+ case __ < 60 { return 'Moet' }
+ else { return 'milk' }
+
+The C<__> subroutine makes extensive use of operator overloading to
+perform its magic. All operations involving __ are overloaded to
+produce an anonymous subroutine that implements a lazy version
+of the original operation.
+
+The only problem is that operator overloading does not allow the
+boolean operators C<&&> and C<||> to be overloaded. So a case statement
+like this:
+
+ case 0 <= __ && __ < 10 { return 'digit' }
+
+doesn't act as expected, because when it is
+executed, it constructs two higher order subroutines
+and then treats the two resulting references as arguments to C<&&>:
+
+ sub { 0 <= $_[0] } && sub { $_[0] < 10 }
+
+This boolean expression is inevitably true, since both references are
+non-false. Fortunately, the overloaded C<'bool'> operator catches this
+situation and flags it as a error.
+
+=head1 DEPENDENCIES
+
+The module is implemented using Filter::Util::Call and Text::Balanced
+and requires both these modules to be installed.
+
+=head1 AUTHOR
+
+Damian Conway ([email protected])
+
+=head1 BUGS
+
+There are undoubtedly serious bugs lurking somewhere in code this funky :-)
+Bug reports and other feedback are most welcome.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Text/Balanced.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Text/Balanced.pm
--- perl/macos/bundled_lib/blib/lib/Text/Balanced.pm.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/blib/lib/Text/Balanced.pm Fri Jul 20 12:30:05 2001
@@ -0,0 +1,997 @@
+# EXTRACT VARIOUSLY DELIMITED TEXT SEQUENCES FROM STRINGS.
+# FOR FULL DOCUMENTATION SEE Balanced.pod
+
+use 5.005;
+use strict;
+
+package Text::Balanced;
+
+use Exporter;
+use SelfLoader;
+use vars qw { $VERSION @ISA %EXPORT_TAGS };
+
+$VERSION = '1.85';
+@ISA = qw ( Exporter );
+
+%EXPORT_TAGS = ( ALL => [ qw(
+ &extract_delimited
+ &extract_bracketed
+ &extract_quotelike
+ &extract_codeblock
+ &extract_variable
+ &extract_tagged
+ &extract_multiple
+
+ &gen_delimited_pat
+ &gen_extract_tagged
+
+ &delimited_pat
+ ) ] );
+
+Exporter::export_ok_tags('ALL');
+
+# PROTOTYPES
+
+sub _match_bracketed($$$$$$);
+sub _match_variable($$);
+sub _match_codeblock($$$$$$$);
+sub _match_quotelike($$$$);
+
+# HANDLE RETURN VALUES IN VARIOUS CONTEXTS
+
+sub _failmsg {
+ my ($message, $pos) = @_;
+ $@ = bless { error=>$message, pos=>$pos }, "Text::Balanced::ErrorMsg";
+}
+
+sub _fail
+{
+ my ($wantarray, $textref, $message, $pos) = @_;
+ _failmsg $message, $pos if $message;
+ return ("",$$textref,"") if $wantarray;
+ return undef;
+}
+
+sub _succeed
+{
+ $@ = undef;
+ my ($wantarray,$textref) = splice @_, 0, 2;
+ my ($extrapos, $extralen) = @_>18 ? splice(@_, -2, 2) : (0,0);
+ my ($startlen) = $_[5];
+ my $remainderpos = $_[2];
+ if ($wantarray)
+ {
+ my @res;
+ while (my ($from, $len) = splice @_, 0, 2)
+ {
+ push @res, substr($$textref,$from,$len);
+ }
+ if ($extralen) { # CORRECT FILLET
+ my $extra = substr($res[0], $extrapos-$startlen, $extralen, "\n");
+ $res[1] = "$extra$res[1]";
+ eval { substr($$textref,$remainderpos,0) = $extra;
+ substr($$textref,$extrapos,$extralen,"\n")} ;
+ #REARRANGE HERE DOC AND FILLET IF POSSIBLE
+ pos($$textref) = $remainderpos-$extralen+1; # RESET \G
+ }
+ else {
+ pos($$textref) = $remainderpos; # RESET \G
+ }
+ return @res;
+ }
+ else
+ {
+ my $match = substr($$textref,$_[0],$_[1]);
+ substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen;
+ my $extra = $extralen
+ ? substr($$textref, $extrapos, $extralen)."\n" : "";
+ eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE
+ pos($$textref) = $_[4]; # RESET \G
+ return $match;
+ }
+}
+
+# BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING
+
+sub gen_delimited_pat($;$) # ($delimiters;$escapes)
+{
+ my ($dels, $escs) = @_;
+ return "" unless $dels =~ /\S/;
+ $escs = '\\' unless $escs;
+ $escs .= substr($escs,-1) x (length($dels)-length($escs));
+ my @pat = ();
+ my $i;
+ for ($i=0; $i<length $dels; $i++)
+ {
+ my $del = quotemeta substr($dels,$i,1);
+ my $esc = quotemeta substr($escs,$i,1);
+ if ($del eq $esc)
+ {
+ push @pat, "$del(?:[^$del]*(?:(?:$del$del)[^$del]*)*)$del";
+ }
+ else
+ {
+ push @pat, "$del(?:[^$esc$del]*(?:$esc.[^$esc$del]*)*)$del";
+ }
+ }
+ my $pat = join '|', @pat;
+ return "(?:$pat)";
+}
+
+*delimited_pat = \&gen_delimited_pat;
+
+
+# THE EXTRACTION FUNCTIONS
+
+sub extract_delimited (;$$$$)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my $wantarray = wantarray;
+ my $del = defined $_[1] ? $_[1] : qq{\'\"\`};
+ my $pre = defined $_[2] ? $_[2] : '\s*';
+ my $esc = defined $_[3] ? $_[3] : qq{\\};
+ my $pat = gen_delimited_pat($del, $esc);
+ my $startpos = pos $$textref || 0;
+ return _fail($wantarray, $textref, "Not a delimited pattern", 0)
+ unless $$textref =~ m/\G($pre)($pat)/gc;
+ my $prelen = length($1);
+ my $matchpos = $startpos+$prelen;
+ my $endpos = pos $$textref;
+ return _succeed $wantarray, $textref,
+ $matchpos, $endpos-$matchpos, # MATCH
+ $endpos, length($$textref)-$endpos, # REMAINDER
+ $startpos, $prelen; # PREFIX
+}
+
+sub extract_bracketed (;$$$)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my $ldel = defined $_[1] ? $_[1] : '{([<';
+ my $pre = defined $_[2] ? $_[2] : '\s*';
+ my $wantarray = wantarray;
+ my $qdel = "";
+ my $quotelike;
+ $ldel =~ s/'//g and $qdel .= q{'};
+ $ldel =~ s/"//g and $qdel .= q{"};
+ $ldel =~ s/`//g and $qdel .= q{`};
+ $ldel =~ s/q//g and $quotelike = 1;
+ $ldel =~ tr/[](){}<>\0-\377/[[(({{<</ds;
+ my $rdel = $ldel;
+ unless ($rdel =~ tr/[({</])}>/)
+ {
+ return _fail $wantarray, $textref,
+ "Did not find a suitable bracket in delimiter: \"$_[1]\"",
+ 0;
+ }
+ my $posbug = pos;
+ $ldel = join('|', map { quotemeta $_ } split('', $ldel));
+ $rdel = join('|', map { quotemeta $_ } split('', $rdel));
+ pos = $posbug;
+
+ my $startpos = pos $$textref || 0;
+ my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel);
+
+ return _fail ($wantarray, $textref) unless @match;
+
+ return _succeed ( $wantarray, $textref,
+ $match[2], $match[5]+2, # MATCH
+ @match[8,9], # REMAINDER
+ @match[0,1], # PREFIX
+ );
+}
+
+sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel
+{
+ my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_;
+ my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0);
+ unless ($$textref =~ m/\G$pre/gc)
+ {
+ _failmsg "Did not find prefix: /$pre/", $startpos;
+ return;
+ }
+
+ $ldelpos = pos $$textref;
+
+ unless ($$textref =~ m/\G($ldel)/gc)
+ {
+ _failmsg "Did not find opening bracket after prefix: \"$pre\"",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+
+ my @nesting = ( $1 );
+ my $textlen = length $$textref;
+ while (pos $$textref < $textlen)
+ {
+ next if $$textref =~ m/\G\\./gcs;
+
+ if ($$textref =~ m/\G($ldel)/gc)
+ {
+ push @nesting, $1;
+ }
+ elsif ($$textref =~ m/\G($rdel)/gc)
+ {
+ my ($found, $brackettype) = ($1, $1);
+ if ($#nesting < 0)
+ {
+ _failmsg "Unmatched closing bracket: \"$found\"",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ my $expected = pop(@nesting);
+ $expected =~ tr/({[</)}]>/;
+ if ($expected ne $brackettype)
+ {
+ _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ last if $#nesting < 0;
+ }
+ elsif ($qdel && $$textref =~ m/\G([$qdel])/gc)
+ {
+ $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next;
+ _failmsg "Unmatched embedded quote ($1)",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ elsif ($quotelike && _match_quotelike($textref,"",1,0))
+ {
+ next;
+ }
+
+ else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs }
+ }
+ if ($#nesting>=0)
+ {
+ _failmsg "Unmatched opening bracket(s): "
+ . join("..",@nesting)."..",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+
+ $endpos = pos $$textref;
+
+ return (
+ $startpos, $ldelpos-$startpos, # PREFIX
+ $ldelpos, 1, # OPENING BRACKET
+ $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS
+ $endpos-1, 1, # CLOSING BRACKET
+ $endpos, length($$textref)-$endpos, # REMAINDER
+ );
+}
+
+sub revbracket($)
+{
+ my $brack = reverse $_[0];
+ $brack =~ tr/[({</])}>/;
+ return $brack;
+}
+
+my $XMLNAME = q{[a-zA-Z_:][a-zA-Z0-9_:.-]*};
+
+sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my $ldel = $_[1];
+ my $rdel = $_[2];
+ my $pre = defined $_[3] ? $_[3] : '\s*';
+ my %options = defined $_[4] ? %{$_[4]} : ();
+ my $omode = defined $options{fail} ? $options{fail} : '';
+ my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
+ : defined($options{reject}) ? $options{reject}
+ : ''
+ ;
+ my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}})
+ : defined($options{ignore}) ? $options{ignore}
+ : ''
+ ;
+
+ if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; }
+ $@ = undef;
+
+ my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
+
+ return _fail(wantarray, $textref) unless @match;
+ return _succeed wantarray, $textref,
+ $match[2], $match[3]+$match[5]+$match[7], # MATCH
+ @match[8..9,0..1,2..7]; # REM, PRE, BITS
+}
+
+sub _match_tagged # ($$$$$$$)
+{
+ my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_;
+ my $rdelspec;
+
+ my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 );
+
+ unless ($$textref =~ m/\G($pre)/gc)
+ {
+ _failmsg "Did not find prefix: /$pre/", pos $$textref;
+ goto failed;
+ }
+
+ $opentagpos = pos($$textref);
+
+ unless ($$textref =~ m/\G$ldel/gc)
+ {
+ _failmsg "Did not find opening tag: /$ldel/", pos $$textref;
+ goto failed;
+ }
+
+ $textpos = pos($$textref);
+
+ if (!defined $rdel)
+ {
+ $rdelspec = $&;
+ unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". revbracket($1) /oes)
+ {
+ _failmsg "Unable to construct closing tag to match: $rdel",
+ pos $$textref;
+ goto failed;
+ }
+ }
+ else
+ {
+ $rdelspec = eval "qq{$rdel}";
+ }
+
+ while (pos($$textref) < length($$textref))
+ {
+ next if $$textref =~ m/\G\\./gc;
+
+ if ($$textref =~ m/\G(\n[ \t]*\n)/gc )
+ {
+ $parapos = pos($$textref) - length($1)
+ unless defined $parapos;
+ }
+ elsif ($$textref =~ m/\G($rdelspec)/gc )
+ {
+ $closetagpos = pos($$textref)-length($1);
+ goto matched;
+ }
+ elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc)
+ {
+ next;
+ }
+ elsif ($bad && $$textref =~ m/\G($bad)/gcs)
+ {
+ pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS
+ goto short if ($omode eq 'PARA' || $omode eq 'MAX');
+ _failmsg "Found invalid nested tag: $1", pos $$textref;
+ goto failed;
+ }
+ elsif ($$textref =~ m/\G($ldel)/gc)
+ {
+ my $tag = $1;
+ pos($$textref) -= length($tag); # REWIND TO NESTED TAG
+ unless (_match_tagged(@_)) # MATCH NESTED TAG
+ {
+ goto short if $omode eq 'PARA' || $omode eq 'MAX';
+ _failmsg "Found unbalanced nested tag: $tag",
+ pos $$textref;
+ goto failed;
+ }
+ }
+ else { $$textref =~ m/./gcs }
+ }
+
+short:
+ $closetagpos = pos($$textref);
+ goto matched if $omode eq 'MAX';
+ goto failed unless $omode eq 'PARA';
+
+ if (defined $parapos) { pos($$textref) = $parapos }
+ else { $parapos = pos($$textref) }
+
+ return (
+ $startpos, $opentagpos-$startpos, # PREFIX
+ $opentagpos, $textpos-$opentagpos, # OPENING TAG
+ $textpos, $parapos-$textpos, # TEXT
+ $parapos, 0, # NO CLOSING TAG
+ $parapos, length($$textref)-$parapos, # REMAINDER
+ );
+
+matched:
+ $endpos = pos($$textref);
+ return (
+ $startpos, $opentagpos-$startpos, # PREFIX
+ $opentagpos, $textpos-$opentagpos, # OPENING TAG
+ $textpos, $closetagpos-$textpos, # TEXT
+ $closetagpos, $endpos-$closetagpos, # CLOSING TAG
+ $endpos, length($$textref)-$endpos, # REMAINDER
+ );
+
+failed:
+ _failmsg "Did not find closing tag", pos $$textref unless $@;
+ pos($$textref) = $startpos;
+ return;
+}
+
+sub extract_variable (;$$)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ return ("","","") unless defined $$textref;
+ my $pre = defined $_[1] ? $_[1] : '\s*';
+
+ my @match = _match_variable($textref,$pre);
+
+ return _fail wantarray, $textref unless @match;
+
+ return _succeed wantarray, $textref,
+ @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX
+}
+
+sub _match_variable($$)
+{
+ my ($textref, $pre) = @_;
+ my $startpos = pos($$textref) = pos($$textref)||0;
+ unless ($$textref =~ m/\G($pre)/gc)
+ {
+ _failmsg "Did not find prefix: /$pre/", pos $$textref;
+ return;
+ }
+ my $varpos = pos($$textref);
+ unless ($$textref =~ m/\G(\$#?|[*\@\%]|\\&)+/gc)
+ {
+ _failmsg "Did not find leading dereferencer", pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+
+ unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci
+ or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0))
+ {
+ _failmsg "Bad identifier after dereferencer", pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+
+ while (1)
+ {
+ next if _match_codeblock($textref,
+ qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/,
+ qr/[({[]/, qr/[)}\]]/,
+ qr/[({[]/, qr/[)}\]]/, 0);
+ next if _match_codeblock($textref,
+ qr/\s*/, qr/[{[]/, qr/[}\]]/,
+ qr/[{[]/, qr/[}\]]/, 0);
+ next if _match_variable($textref,'\s*->\s*');
+ next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc;
+ last;
+ }
+
+ my $endpos = pos($$textref);
+ return ($startpos, $varpos-$startpos,
+ $varpos, $endpos-$varpos,
+ $endpos, length($$textref)-$endpos
+ );
+}
+
+sub extract_codeblock (;$$$$$)
+{
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my $wantarray = wantarray;
+ my $ldel_inner = defined $_[1] ? $_[1] : '{';
+ my $pre = defined $_[2] ? $_[2] : '\s*';
+ my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner;
+ my $rd = $_[4];
+ my $rdel_inner = $ldel_inner;
+ my $rdel_outer = $ldel_outer;
+ my $posbug = pos;
+ for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds }
+ for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds }
+ for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer)
+ {
+ $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')'
+ }
+ pos = $posbug;
+
+ my @match = _match_codeblock($textref, $pre,
+ $ldel_outer, $rdel_outer,
+ $ldel_inner, $rdel_inner,
+ $rd);
+ return _fail($wantarray, $textref) unless @match;
+ return _succeed($wantarray, $textref,
+ @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX
+ );
+
+}
+
+sub _match_codeblock($$$$$$$)
+{
+ my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_;
+ my $startpos = pos($$textref) = pos($$textref) || 0;
+ unless ($$textref =~ m/\G($pre)/gc)
+ {
+ _failmsg qq{Did not match prefix /$pre/ at"} .
+ substr($$textref,pos($$textref),20) .
+ q{..."},
+ pos $$textref;
+ return;
+ }
+ my $codepos = pos($$textref);
+ unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER
+ {
+ _failmsg qq{Did not find expected opening bracket at "} .
+ substr($$textref,pos($$textref),20) .
+ q{..."},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ my $closing = $1;
+ $closing =~ tr/([<{/)]>}/;
+ my $matched;
+ my $patvalid = 1;
+ while (pos($$textref) < length($$textref))
+ {
+ $matched = '';
+ if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc)
+ {
+ $patvalid = 0;
+ next;
+ }
+
+ if ($$textref =~ m/\G\s*#.*/gc)
+ {
+ next;
+ }
+
+ if ($$textref =~ m/\G\s*($rdel_outer)/gc)
+ {
+ unless ($matched = ($closing && $1 eq $closing) )
+ {
+ next if $1 eq '>'; # MIGHT BE A "LESS THAN"
+ _failmsg q{Mismatched closing bracket at "} .
+ substr($$textref,pos($$textref),20) .
+ qq{...". Expected '$closing'},
+ pos $$textref;
+ }
+ last;
+ }
+
+ if (_match_variable($textref,'\s*') ||
+ _match_quotelike($textref,'\s*',$patvalid,$patvalid) )
+ {
+ $patvalid = 0;
+ next;
+ }
+
+
+ # NEED TO COVER MANY MORE CASES HERE!!!
+ if ($$textref =~ m#\G\s*( [-+*x/%^&|.]=?
+ | =(?!>)
+ | (\*\*|&&|\|\||<<|>>)=?
+ | [!=][~=]
+ | split|grep|map|return
+ )#gcx)
+ {
+ $patvalid = 1;
+ next;
+ }
+
+ if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) )
+ {
+ $patvalid = 1;
+ next;
+ }
+
+ if ($$textref =~ m/\G\s*$ldel_outer/gc)
+ {
+ _failmsg q{Improperly nested codeblock at "} .
+ substr($$textref,pos($$textref),20) .
+ q{..."},
+ pos $$textref;
+ last;
+ }
+
+ $patvalid = 0;
+ $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc;
+ }
+ continue { $@ = undef }
+
+ unless ($matched)
+ {
+ _failmsg 'No match found for opening bracket', pos $$textref
+ unless $@;
+ return;
+ }
+
+ my $endpos = pos($$textref);
+ return ( $startpos, $codepos-$startpos,
+ $codepos, $endpos-$codepos,
+ $endpos, length($$textref)-$endpos,
+ );
+}
+
+
+my %mods = (
+ 'none' => '[cgimsox]*',
+ 'm' => '[cgimsox]*',
+ 's' => '[cegimsox]*',
+ 'tr' => '[cds]*',
+ 'y' => '[cds]*',
+ 'qq' => '',
+ 'qx' => '',
+ 'qw' => '',
+ 'qr' => '[imsx]*',
+ 'q' => '',
+ );
+
+sub extract_quotelike (;$$)
+{
+ my $textref = $_[0] ? \$_[0] : \$_;
+ my $wantarray = wantarray;
+ my $pre = defined $_[1] ? $_[1] : '\s*';
+
+ my @match = _match_quotelike($textref,$pre,1,0);
+ return _fail($wantarray, $textref) unless @match;
+ return _succeed($wantarray, $textref,
+ $match[2], $match[18]-$match[2], # MATCH
+ @match[18,19], # REMAINDER
+ @match[0,1], # PREFIX
+ @match[2..17], # THE BITS
+ @match[20,21], # ANY FILLET?
+ );
+};
+
+sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match)
+{
+ my ($textref, $pre, $rawmatch, $qmark) = @_;
+
+ my ($textlen,$startpos,
+ $oppos,
+ $preld1pos,$ld1pos,$str1pos,$rd1pos,
+ $preld2pos,$ld2pos,$str2pos,$rd2pos,
+ $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 );
+
+ unless ($$textref =~ m/\G($pre)/gc)
+ {
+ _failmsg qq{Did not find prefix /$pre/ at "} .
+ substr($$textref, pos($$textref), 20) .
+ q{..."},
+ pos $$textref;
+ return;
+ }
+ $oppos = pos($$textref);
+
+ my $initial = substr($$textref,$oppos,1);
+
+ if ($initial && $initial =~ m|^[\"\'\`]|
+ || $rawmatch && $initial =~ m|^/|
+ || $qmark && $initial =~ m|^\?|)
+ {
+ unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx)
+ {
+ _failmsg qq{Did not find closing delimiter to match '$initial' at "} .
+ substr($$textref, $oppos, 20) .
+ q{..."},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ $modpos= pos($$textref);
+ $rd1pos = $modpos-1;
+
+ if ($initial eq '/' || $initial eq '?')
+ {
+ $$textref =~ m/\G$mods{none}/gc
+ }
+
+ my $endpos = pos($$textref);
+ return (
+ $startpos, $oppos-$startpos, # PREFIX
+ $oppos, 0, # NO OPERATOR
+ $oppos, 1, # LEFT DEL
+ $oppos+1, $rd1pos-$oppos-1, # STR/PAT
+ $rd1pos, 1, # RIGHT DEL
+ $modpos, 0, # NO 2ND LDEL
+ $modpos, 0, # NO 2ND STR
+ $modpos, 0, # NO 2ND RDEL
+ $modpos, $endpos-$modpos, # MODIFIERS
+ $endpos, $textlen-$endpos, # REMAINDER
+ );
+ }
+
+ unless ($$textref =~ m{\G((?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc)
+ {
+ _failmsg q{No quotelike operator found after prefix at "} .
+ substr($$textref, pos($$textref), 20) .
+ q{..."},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+
+ my $op = $1;
+ $preld1pos = pos($$textref);
+ if ($op eq '<<') {
+ $ld1pos = pos($$textref);
+ my $label;
+ if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) {
+ $label = $1;
+ }
+ elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) '
+ | \G " ([^"\\]* (?:\\.[^"\\]*)*) "
+ | \G ` ([^`\\]* (?:\\.[^`\\]*)*) `
+ }gcsx) {
+ $label = $+;
+ }
+ else {
+ $label = "";
+ }
+ my $extrapos = pos($$textref);
+ $$textref =~ m{.*\n}gc;
+ $str1pos = pos($$textref);
+ unless ($$textref =~ m{.*?\n(?=$label\n)}gc) {
+ _failmsg qq{Missing here doc terminator ('$label') after "} .
+ substr($$textref, $startpos, 20) .
+ q{..."},
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ $rd1pos = pos($$textref);
+ $$textref =~ m{$label\n}gc;
+ $ld2pos = pos($$textref);
+ return (
+ $startpos, $oppos-$startpos, # PREFIX
+ $oppos, length($op), # OPERATOR
+ $ld1pos, $extrapos-$ld1pos, # LEFT DEL
+ $str1pos, $rd1pos-$str1pos, # STR/PAT
+ $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL
+ $ld2pos, 0, # NO 2ND LDEL
+ $ld2pos, 0, # NO 2ND STR
+ $ld2pos, 0, # NO 2ND RDEL
+ $ld2pos, 0, # NO MODIFIERS
+ $ld2pos, $textlen-$ld2pos, # REMAINDER
+ $extrapos, $str1pos-$extrapos, # FILLETED BIT
+ );
+ }
+
+ $$textref =~ m/\G\s*/gc;
+ $ld1pos = pos($$textref);
+ $str1pos = $ld1pos+1;
+
+ unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD
+ {
+ _failmsg "No block delimiter found after quotelike $op",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN
+ my ($ldel1, $rdel1) = ("\Q$1","\Q$1");
+ if ($ldel1 =~ /[[(<{]/)
+ {
+ $rdel1 =~ tr/[({</])}>/;
+ _match_bracketed($textref,"",$ldel1,"","",$rdel1)
+ || do { pos $$textref = $startpos; return };
+ }
+ else
+ {
+ $$textref =~ /$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs
+ || do { pos $$textref = $startpos; return };
+ }
+ $ld2pos = $rd1pos = pos($$textref)-1;
+
+ my $second_arg = $op =~ /s|tr|y/ ? 1 : 0;
+ if ($second_arg)
+ {
+ my ($ldel2, $rdel2);
+ if ($ldel1 =~ /[[(<{]/)
+ {
+ unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD
+ {
+ _failmsg "Missing second block for quotelike $op",
+ pos $$textref;
+ pos $$textref = $startpos;
+ return;
+ }
+ $ldel2 = $rdel2 = "\Q$1";
+ $rdel2 =~ tr/[({</])}>/;
+ }
+ else
+ {
+ $ldel2 = $rdel2 = $ldel1;
+ }
+ $str2pos = $ld2pos+1;
+
+ if ($ldel2 =~ /[[(<{]/)
+ {
+ pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD
+ _match_bracketed($textref,"",$ldel2,"","",$rdel2)
+ || do { pos $$textref = $startpos; return };
+ }
+ else
+ {
+ $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs
+ || do { pos $$textref = $startpos; return };
+ }
+ $rd2pos = pos($$textref)-1;
+ }
+ else
+ {
+ $ld2pos = $str2pos = $rd2pos = $rd1pos;
+ }
+
+ $modpos = pos $$textref;
+
+ $$textref =~ m/\G($mods{$op})/gc;
+ my $endpos = pos $$textref;
+
+ return (
+ $startpos, $oppos-$startpos, # PREFIX
+ $oppos, length($op), # OPERATOR
+ $ld1pos, 1, # LEFT DEL
+ $str1pos, $rd1pos-$str1pos, # STR/PAT
+ $rd1pos, 1, # RIGHT DEL
+ $ld2pos, $second_arg, # 2ND LDEL (MAYBE)
+ $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE)
+ $rd2pos, $second_arg, # 2ND RDEL (MAYBE)
+ $modpos, $endpos-$modpos, # MODIFIERS
+ $endpos, $textlen-$endpos, # REMAINDER
+ );
+}
+
+my $def_func =
+[
+ sub { extract_variable($_[0], '') },
+ sub { extract_quotelike($_[0],'') },
+ sub { extract_codeblock($_[0],'{}','') },
+];
+
+sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown)
+{
+ my $textref = defined($_[0]) ? \$_[0] : \$_;
+ my $posbug = pos;
+ my ($lastpos, $firstpos);
+ my @fields = ();
+
+ for ($$textref)
+ {
+ my @func = defined $_[1] ? @{$_[1]} : @{$def_func};
+ my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000;
+ my $igunk = $_[3];
+
+ pos ||= 0;
+
+ unless (wantarray)
+ {
+ use Carp;
+ carp "extract_multiple reset maximal count to 1 in scalar context"
+ if $^W && defined($_[2]) && $max > 1;
+ $max = 1
+ }
+
+ my $unkpos;
+ my $func;
+ my $class;
+
+ my @class;
+ foreach $func ( @func )
+ {
+ if (ref($func) eq 'HASH')
+ {
+ push @class, (keys %$func)[0];
+ $func = (values %$func)[0];
+ }
+ else
+ {
+ push @class, undef;
+ }
+ }
+
+ FIELD: while (pos() < length())
+ {
+ my $field;
+ foreach my $i ( 0..$#func )
+ {
+ $func = $func[$i];
+ $class = $class[$i];
+ $lastpos = pos;
+ if (ref($func) eq 'CODE')
+ { ($field) = $func->($_) }
+ elsif (ref($func) eq 'Text::Balanced::Extractor')
+ { $field = $func->extract($_) }
+ elsif( m/\G$func/gc )
+ { $field = defined($1) ? $1 : $& }
+
+ if (defined($field) && length($field))
+ {
+ if (defined($unkpos) && !$igunk)
+ {
+ push @fields, substr($_, $unkpos, $lastpos-$unkpos);
+ $firstpos = $unkpos unless defined $firstpos;
+ undef $unkpos;
+ last FIELD if @fields == $max;
+ }
+ push @fields, $class
+ ? bless(\$field, $class)
+ : $field;
+ $firstpos = $lastpos unless defined $firstpos;
+ $lastpos = pos;
+ last FIELD if @fields == $max;
+ next FIELD;
+ }
+ }
+ if (/\G(.)/gcs)
+ {
+ $unkpos = pos()-1
+ unless $igunk || defined $unkpos;
+ }
+ }
+
+ if (defined $unkpos)
+ {
+ push @fields, substr($_, $unkpos);
+ $firstpos = $unkpos unless defined $firstpos;
+ $lastpos = length;
+ }
+ last;
+ }
+
+ pos $$textref = $lastpos;
+ return @fields if wantarray;
+
+ $firstpos ||= 0;
+ eval { substr($$textref,$firstpos,$lastpos-$firstpos)="";
+ pos $$textref = $firstpos };
+ return $fields[0];
+}
+
+
+sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options)
+{
+ my $ldel = $_[0];
+ my $rdel = $_[1];
+ my $pre = defined $_[2] ? $_[2] : '\s*';
+ my %options = defined $_[3] ? %{$_[3]} : ();
+ my $omode = defined $options{fail} ? $options{fail} : '';
+ my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
+ : defined($options{reject}) ? $options{reject}
+ : ''
+ ;
+ my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}})
+ : defined($options{ignore}) ? $options{ignore}
+ : ''
+ ;
+
+ if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; }
+
+ my $posbug = pos;
+ for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ }
+ pos = $posbug;
+
+ my $closure = sub
+ {
+ my $textref = defined $_[0] ? \$_[0] : \$_;
+ my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
+
+ return _fail(wantarray, $textref) unless @match;
+ return _succeed wantarray, $textref,
+ $match[2], $match[3]+$match[5]+$match[7], # MATCH
+ @match[8..9,0..1,2..7]; # REM, PRE, BITS
+ };
+
+ bless $closure, 'Text::Balanced::Extractor';
+}
+
+package Text::Balanced::Extractor;
+
+sub extract($$) # ($self, $text)
+{
+ &{$_[0]}($_[1]);
+}
+
+package Text::Balanced::ErrorMsg;
+
+use overload '""' => sub { "$_[0]->{error}, detected at offset $_[0]->{pos}" };
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Text/Balanced.pod#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Text/Balanced.pod
--- perl/macos/bundled_lib/blib/lib/Text/Balanced.pod.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/blib/lib/Text/Balanced.pod Fri Jul 20 12:30:05 2001
@@ -0,0 +1,1205 @@
+=head1 NAME
+
+Text::Balanced - Extract delimited text sequences from strings.
+
+
+=head1 SYNOPSIS
+
+ use Text::Balanced qw (
+ extract_delimited
+ extract_bracketed
+ extract_quotelike
+ extract_codeblock
+ extract_variable
+ extract_tagged
+ extract_multiple
+
+ gen_delimited_pat
+ gen_extract_tagged
+ );
+
+ # Extract the initial substring of $text that is delimited by
+ # two (unescaped) instances of the first character in $delim.
+
+ ($extracted, $remainder) = extract_delimited($text,$delim);
+
+
+ # Extract the initial substring of $text that is bracketed
+ # with a delimiter(s) specified by $delim (where the string
+ # in $delim contains one or more of '(){}[]<>').
+
+ ($extracted, $remainder) = extract_bracketed($text,$delim);
+
+
+ # Extract the initial substring of $text that is bounded by
+ # an HTML/XML tag.
+
+ ($extracted, $remainder) = extract_tagged($text);
+
+
+ # Extract the initial substring of $text that is bounded by
+ # a C<BEGIN>...C<END> pair. Don't allow nested C<BEGIN> tags
+
+ ($extracted, $remainder) =
+ extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]});
+
+
+ # Extract the initial substring of $text that represents a
+ # Perl "quote or quote-like operation"
+
+ ($extracted, $remainder) = extract_quotelike($text);
+
+
+ # Extract the initial substring of $text that represents a block
+ # of Perl code, bracketed by any of character(s) specified by $delim
+ # (where the string $delim contains one or more of '(){}[]<>').
+
+ ($extracted, $remainder) = extract_codeblock($text,$delim);
+
+
+ # Extract the initial substrings of $text that would be extracted by
+ # one or more sequential applications of the specified functions
+ # or regular expressions
+
+ @extracted = extract_multiple($text,
+ [ \&extract_bracketed,
+ \&extract_quotelike,
+ \&some_other_extractor_sub,
+ qr/[xyz]*/,
+ 'literal',
+ ]);
+
+# Create a string representing an optimized pattern (a la Friedl)
+# that matches a substring delimited by any of the specified characters
+# (in this case: any type of quote or a slash)
+
+ $patstring = gen_delimited_pat(q{'"`/});
+
+
+# Generate a reference to an anonymous sub that is just like extract_tagged
+# but pre-compiled and optimized for a specific pair of tags, and consequently
+# much faster (i.e. 3 times faster). It uses qr// for better performance on
+# repeated calls, so it only works under Perl 5.005 or later.
+
+ $extract_head = gen_extract_tagged('<HEAD>','</HEAD>');
+
+ ($extracted, $remainder) = $extract_head->($text);
+
+
+=head1 DESCRIPTION
+
+The various C<extract_...> subroutines may be used to extract a
+delimited string (possibly after skipping a specified prefix string).
+The search for the string always begins at the current C<pos>
+location of the string's variable (or at index zero, if no C<pos>
+position is defined).
+
+=head2 General behaviour in list contexts
+
+In a list context, all the subroutines return a list, the first three
+elements of which are always:
+
+=over 4
+
+=item [0]
+
+The extracted string, including the specified delimiters.
+If the extraction fails an empty string is returned.
+
+=item [1]
+
+The remainder of the input string (i.e. the characters after the
+extracted string). On failure, the entire string is returned.
+
+=item [2]
+
+The skipped prefix (i.e. the characters before the extracted string).
+On failure, the empty string is returned.
+
+=back
+
+Note that in a list context, the contents of the original input text (the first
+argument) are not modified in any way.
+
+However, if the input text was passed in a variable, that variable's
+C<pos> value is updated to point at the first character after the
+extracted text. That means that in a list context the various
+subroutines can be used much like regular expressions. For example:
+
+ while ( $next = (extract_quotelike($text))[0] )
+ {
+ # process next quote-like (in $next)
+ }
+
+
+=head2 General behaviour in scalar and void contexts
+
+In a scalar context, the extracted string is returned, having first been
+removed from the input text. Thus, the following code also processes
+each quote-like operation, but actually removes them from $text:
+
+ while ( $next = extract_quotelike($text) )
+ {
+ # process next quote-like (in $next)
+ }
+
+Note that if the input text is a read-only string (i.e. a literal),
+no attempt is made to remove the extracted text.
+
+In a void context the behaviour of the extraction subroutines is
+exactly the same as in a scalar context, except (of course) that the
+extracted substring is not returned.
+
+=head2 A note about prefixes
+
+Prefix patterns are matched without any trailing modifiers (C</gimsox> etc.)
+This can bite you if you're expecting a prefix specification like
+'.*?(?=<H1>)' to skip everything up to the first <H1> tag. Such a prefix
+pattern will only succeed if the <H1> tag is on the current line, since
+. normally doesn't match newlines.
+
+To overcome this limitation, you need to turn on /s matching within
+the prefix pattern, using the C<(?s)> directive: '(?s).*?(?=<H1>)'
+
+
+=head2 C<extract_delimited>
+
+The C<extract_delimited> function formalizes the common idiom
+of extracting a single-character-delimited substring from the start of
+a string. For example, to extract a single-quote delimited string, the
+following code is typically used:
+
+ ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s;
+ $extracted = $1;
+
+but with C<extract_delimited> it can be simplified to:
+
+ ($extracted,$remainder) = extract_delimited($text, "'");
+
+C<extract_delimited> takes up to four scalars (the input text, the
+delimiters, a prefix pattern to be skipped, and any escape characters)
+and extracts the initial substring of the text that
+is appropriately delimited. If the delimiter string has multiple
+characters, the first one encountered in the text is taken to delimit
+the substring.
+The third argument specifies a prefix pattern that is to be skipped
+(but must be present!) before the substring is extracted.
+The final argument specifies the escape character to be used for each
+delimiter.
+
+All arguments are optional. If the escape characters are not specified,
+every delimiter is escaped with a backslash (C<\>).
+If the prefix is not specified, the
+pattern C<'\s*'> - optional whitespace - is used. If the delimiter set
+is also not specified, the set C</["'`]/> is used. If the text to be processed
+is not specified either, C<$_> is used.
+
+In list context, C<extract_delimited> returns a array of three
+elements, the extracted substring (I<including the surrounding
+delimiters>), the remainder of the text, and the skipped prefix (if
+any). If a suitable delimited substring is not found, the first
+element of the array is the empty string, the second is the complete
+original text, and the prefix returned in the third element is an
+empty string.
+
+In a scalar context, just the extracted substring is returned. In
+a void context, the extracted substring (and any prefix) are simply
+removed from the beginning of the first argument.
+
+Examples:
+
+ # Remove a single-quoted substring from the very beginning of $text:
+
+ $substring = extract_delimited($text, "'", '');
+
+ # Remove a single-quoted Pascalish substring (i.e. one in which
+ # doubling the quote character escapes it) from the very
+ # beginning of $text:
+
+ $substring = extract_delimited($text, "'", '', "'");
+
+ # Extract a single- or double- quoted substring from the
+ # beginning of $text, optionally after some whitespace
+ # (note the list context to protect $text from modification):
+
+ ($substring) = extract_delimited $text, q{"'};
+
+
+ # Delete the substring delimited by the first '/' in $text:
+
+ $text = join '', (extract_delimited($text,'/','[^/]*')[2,1];
+
+Note that this last example is I<not> the same as deleting the first
+quote-like pattern. For instance, if C<$text> contained the string:
+
+ "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }"
+
+then after the deletion it would contain:
+
+ "if ('.$UNIXCMD/s) { $cmd = $1; }"
+
+not:
+
+ "if ('./cmd' =~ ms) { $cmd = $1; }"
+
+
+See L<"extract_quotelike"> for a (partial) solution to this problem.
+
+
+=head2 C<extract_bracketed>
+
+Like C<"extract_delimited">, the C<extract_bracketed> function takes
+up to three optional scalar arguments: a string to extract from, a delimiter
+specifier, and a prefix pattern. As before, a missing prefix defaults to
+optional whitespace and a missing text defaults to C<$_>. However, a missing
+delimiter specifier defaults to C<'{}()[]E<lt>E<gt>'> (see below).
+
+C<extract_bracketed> extracts a balanced-bracket-delimited
+substring (using any one (or more) of the user-specified delimiter
+brackets: '(..)', '{..}', '[..]', or '<..>'). Optionally it will also
+respect quoted unbalanced brackets (see below).
+
+A "delimiter bracket" is a bracket in list of delimiters passed as
+C<extract_bracketed>'s second argument. Delimiter brackets are
+specified by giving either the left or right (or both!) versions
+of the required bracket(s). Note that the order in which
+two or more delimiter brackets are specified is not significant.
+
+A "balanced-bracket-delimited substring" is a substring bounded by
+matched brackets, such that any other (left or right) delimiter
+bracket I<within> the substring is also matched by an opposite
+(right or left) delimiter bracket I<at the same level of nesting>. Any
+type of bracket not in the delimiter list is treated as an ordinary
+character.
+
+In other words, each type of bracket specified as a delimiter must be
+balanced and correctly nested within the substring, and any other kind of
+("non-delimiter") bracket in the substring is ignored.
+
+For example, given the string:
+
+ $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }";
+
+then a call to C<extract_bracketed> in a list context:
+
+ @result = extract_bracketed( $text, '{}' );
+
+would return:
+
+ ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" )
+
+since both sets of C<'{..}'> brackets are properly nested and evenly balanced.
+(In a scalar context just the first element of the array would be returned. In
+a void context, C<$text> would be replaced by an empty string.)
+
+Likewise the call in:
+
+ @result = extract_bracketed( $text, '{[' );
+
+would return the same result, since all sets of both types of specified
+delimiter brackets are correctly nested and balanced.
+
+However, the call in:
+
+ @result = extract_bracketed( $text, '{([<' );
+
+would fail, returning:
+
+ ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" );
+
+because the embedded pairs of C<'(..)'>s and C<'[..]'>s are "cross-nested" and
+the embedded C<'E<gt>'> is unbalanced. (In a scalar context, this call would
+return an empty string. In a void context, C<$text> would be unchanged.)
+
+Note that the embedded single-quotes in the string don't help in this
+case, since they have not been specified as acceptable delimiters and are
+therefore treated as non-delimiter characters (and ignored).
+
+However, if a particular species of quote character is included in the
+delimiter specification, then that type of quote will be correctly handled.
+for example, if C<$text> is:
+
+ $text = '<A HREF=">>>>">link</A>';
+
+then
+
+ @result = extract_bracketed( $text, '<">' );
+
+returns:
+
+ ( '<A HREF=">>>>">', 'link</A>', "" )
+
+as expected. Without the specification of C<"> as an embedded quoter:
+
+ @result = extract_bracketed( $text, '<>' );
+
+the result would be:
+
+ ( '<A HREF=">', '>>>">link</A>', "" )
+
+In addition to the quote delimiters C<'>, C<">, and C<`>, full Perl quote-like
+quoting (i.e. q{string}, qq{string}, etc) can be specified by including the
+letter 'q' as a delimiter. Hence:
+
+ @result = extract_bracketed( $text, '<q>' );
+
+would correctly match something like this:
+
+ $text = '<leftop: conj /and/ conj>';
+
+See also: C<"extract_quotelike"> and C<"extract_codeblock">.
+
+
+=head2 C<extract_tagged>
+
+C<extract_tagged> extracts and segments text between (balanced)
+specified tags.
+
+The subroutine takes up to five optional arguments:
+
+=over 4
+
+=item 1.
+
+A string to be processed (C<$_> if the string is omitted or C<undef>)
+
+=item 2.
+
+A string specifying a pattern to be matched as the opening tag.
+If the pattern string is omitted (or C<undef>) then a pattern
+that matches any standard HTML/XML tag is used.
+
+=item 3.
+
+A string specifying a pattern to be matched at the closing tag.
+If the pattern string is omitted (or C<undef>) then the closing
+tag is constructed by inserting a C</> after any leading bracket
+characters in the actual opening tag that was matched (I<not> the pattern
+that matched the tag). For example, if the opening tag pattern
+is specified as C<'{{\w+}}'> and actually matched the opening tag
+C<"{{DATA}}">, then the constructed closing tag would be C<"{{/DATA}}">.
+
+=item 4.
+
+A string specifying a pattern to be matched as a prefix (which is to be
+skipped). If omitted, optional whitespace is skipped.
+
+=item 5.
+
+A hash reference containing various parsing options (see below)
+
+=back
+
+The various options that can be specified are:
+
+=over 4
+
+=item C<reject =E<gt> $listref>
+
+The list reference contains one or more strings specifying patterns
+that must I<not> appear within the tagged text.
+
+For example, to extract
+an HTML link (which should not contain nested links) use:
+
+ extract_tagged($text, '<A>', '</A>', undef, {reject => ['<A>']} );
+
+=item C<ignore =E<gt> $listref>
+
+The list reference contains one or more strings specifying patterns
+that are I<not> be be treated as nested tags within the tagged text
+(even if they would match the start tag pattern).
+
+For example, to extract an arbitrary XML tag, but ignore "empty" elements:
+
+ extract_tagged($text, undef, undef, undef, {ignore => ['<[^>]*/>']} );
+
+(also see L<"gen_delimited_pat"> below).
+
+
+=item C<fail =E<gt> $str>
+
+The C<fail> option indicates the action to be taken if a matching end
+tag is not encountered (i.e. before the end of the string or some
+C<reject> pattern matches). By default, a failure to match a closing
+tag causes C<extract_tagged> to immediately fail.
+
+However, if the string value associated with <reject> is "MAX", then
+C<extract_tagged> returns the complete text up to the point of failure.
+If the string is "PARA", C<extract_tagged> returns only the first paragraph
+after the tag (up to the first line that is either empty or contains
+only whitespace characters).
+If the string is "", the the default behaviour (i.e. failure) is reinstated.
+
+For example, suppose the start tag "/para" introduces a paragraph, which then
+continues until the next "/endpara" tag or until another "/para" tag is
+encountered:
+
+ $text = "/para line 1\n\nline 3\n/para line 4";
+
+ extract_tagged($text, '/para', '/endpara', undef,
+ {reject => '/para', fail => MAX );
+
+ # EXTRACTED: "/para line 1\n\nline 3\n"
+
+Suppose instead, that if no matching "/endpara" tag is found, the "/para"
+tag refers only to the immediately following paragraph:
+
+ $text = "/para line 1\n\nline 3\n/para line 4";
+
+ extract_tagged($text, '/para', '/endpara', undef,
+ {reject => '/para', fail => MAX );
+
+ # EXTRACTED: "/para line 1\n"
+
+Note that the specified C<fail> behaviour applies to nested tags as well.
+
+=back
+
+On success in a list context, an array of 6 elements is returned. The elements are:
+
+=over 4
+
+=item [0]
+
+the extracted tagged substring (including the outermost tags),
+
+=item [1]
+
+the remainder of the input text,
+
+=item [2]
+
+the prefix substring (if any),
+
+=item [3]
+
+the opening tag
+
+=item [4]
+
+the text between the opening and closing tags
+
+=item [5]
+
+the closing tag (or "" if no closing tag was found)
+
+=back
+
+On failure, all of these values (except the remaining text) are C<undef>.
+
+In a scalar context, C<extract_tagged> returns just the complete
+substring that matched a tagged text (including the start and end
+tags). C<undef> is returned on failure. In addition, the original input
+text has the returned substring (and any prefix) removed from it.
+
+In a void context, the input text just has the matched substring (and
+any specified prefix) removed.
+
+
+=head2 C<gen_extract_tagged>
+
+(Note: This subroutine is only available under Perl5.005)
+
+C<gen_extract_tagged> generates a new anonymous subroutine which
+extracts text between (balanced) specified tags. In other words,
+it generates a function identical in function to C<extract_tagged>.
+
+The difference between C<extract_tagged> and the anonymous
+subroutines generated by
+C<gen_extract_tagged>, is that those generated subroutines:
+
+=over 4
+
+=item *
+
+do not have to reparse tag specification or parsing options every time
+they are called (whereas C<extract_tagged> has to effectively rebuild
+its tag parser on every call);
+
+=item *
+
+make use of the new qr// construct to pre-compile the regexes they use
+(whereas C<extract_tagged> uses standard string variable interpolation
+to create tag-matching patterns).
+
+=back
+
+The subroutine takes up to four optional arguments (the same set as
+C<extract_tagged> except for the string to be processed). It returns
+a reference to a subroutine which in turn takes a single argument (the text to
+be extracted from).
+
+In other words, the implementation of C<extract_tagged> is exactly
+equivalent to:
+
+ sub extract_tagged
+ {
+ my $text = shift;
+ $extractor = gen_extract_tagged(@_);
+ return $extractor->($text);
+ }
+
+(although C<extract_tagged> is not currently implemented that way, in order
+to preserve pre-5.005 compatibility).
+
+Using C<gen_extract_tagged> to create extraction functions for specific tags
+is a good idea if those functions are going to be called more than once, since
+their performance is typically twice as good as the more general-purpose
+C<extract_tagged>.
+
+
+=head2 C<extract_quotelike>
+
+C<extract_quotelike> attempts to recognize, extract, and segment any
+one of the various Perl quotes and quotelike operators (see
+L<perlop(3)>) Nested backslashed delimiters, embedded balanced bracket
+delimiters (for the quotelike operators), and trailing modifiers are
+all caught. For example, in:
+
+ extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #'
+
+ extract_quotelike ' "You said, \"Use sed\"." '
+
+ extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; '
+
+ extract_quotelike ' tr/\\\/\\\\/\\\//ds; '
+
+the full Perl quotelike operations are all extracted correctly.
+
+Note too that, when using the /x modifier on a regex, any comment
+containing the current pattern delimiter will cause the regex to be
+immediately terminated. In other words:
+
+ 'm /
+ (?i) # CASE INSENSITIVE
+ [a-z_] # LEADING ALPHABETIC/UNDERSCORE
+ [a-z0-9]* # FOLLOWED BY ANY NUMBER OF ALPHANUMERICS
+ /x'
+
+will be extracted as if it were:
+
+ 'm /
+ (?i) # CASE INSENSITIVE
+ [a-z_] # LEADING ALPHABETIC/'
+
+This behaviour is identical to that of the actual compiler.
+
+C<extract_quotelike> takes two arguments: the text to be processed and
+a prefix to be matched at the very beginning of the text. If no prefix
+is specified, optional whitespace is the default. If no text is given,
+C<$_> is used.
+
+In a list context, an array of 11 elements is returned. The elements are:
+
+=over 4
+
+=item [0]
+
+the extracted quotelike substring (including trailing modifiers),
+
+=item [1]
+
+the remainder of the input text,
+
+=item [2]
+
+the prefix substring (if any),
+
+=item [3]
+
+the name of the quotelike operator (if any),
+
+=item [4]
+
+the left delimiter of the first block of the operation,
+
+=item [5]
+
+the text of the first block of the operation
+(that is, the contents of
+a quote, the regex of a match or substitution or the target list of a
+translation),
+
+=item [6]
+
+the right delimiter of the first block of the operation,
+
+=item [7]
+
+the left delimiter of the second block of the operation
+(that is, if it is a C<s>, C<tr>, or C<y>),
+
+=item [8]
+
+the text of the second block of the operation
+(that is, the replacement of a substitution or the translation list
+of a translation),
+
+=item [9]
+
+the right delimiter of the second block of the operation (if any),
+
+=item [10]
+
+the trailing modifiers on the operation (if any).
+
+=back
+
+For each of the fields marked "(if any)" the default value on success is
+an empty string.
+On failure, all of these values (except the remaining text) are C<undef>.
+
+
+In a scalar context, C<extract_quotelike> returns just the complete substring
+that matched a quotelike operation (or C<undef> on failure). In a scalar or
+void context, the input text has the same substring (and any specified
+prefix) removed.
+
+Examples:
+
+ # Remove the first quotelike literal that appears in text
+
+ $quotelike = extract_quotelike($text,'.*?');
+
+ # Replace one or more leading whitespace-separated quotelike
+ # literals in $_ with "<QLL>"
+
+ do { $_ = join '<QLL>', (extract_quotelike)[2,1] } until $@;
+
+
+ # Isolate the search pattern in a quotelike operation from $text
+
+ ($op,$pat) = (extract_quotelike $text)[3,5];
+ if ($op =~ /[ms]/)
+ {
+ print "search pattern: $pat\n";
+ }
+ else
+ {
+ print "$op is not a pattern matching operation\n";
+ }
+
+
+=head2 C<extract_quotelike> and "here documents"
+
+C<extract_quotelike> can successfully extract "here documents" from an input
+string, but with an important caveat in list contexts.
+
+Unlike other types of quote-like literals, a here document is rarely
+a contiguous substring. For example, a typical piece of code using
+here document might look like this:
+
+ <<'EOMSG' || die;
+ This is the message.
+ EOMSG
+ exit;
+
+Given this as an input string in a scalar context, C<extract_quotelike>
+would correctly return the string "<<'EOMSG'\nThis is the message.\nEOMSG",
+leaving the string " || die;\nexit;" in the original variable. In other words,
+the two separate pieces of the here document are successfully extracted and
+concatenated.
+
+In a list context, C<extract_quotelike> would return the list
+
+=over 4
+
+=item [0]
+
+"<<'EOMSG'\nThis is the message.\nEOMSG\n" (i.e. the full extracted here document,
+including fore and aft delimiters),
+
+=item [1]
+
+" || die;\nexit;" (i.e. the remainder of the input text, concatenated),
+
+=item [2]
+
+"" (i.e. the prefix substring -- trivial in this case),
+
+=item [3]
+
+"<<" (i.e. the "name" of the quotelike operator)
+
+=item [4]
+
+"'EOMSG'" (i.e. the left delimiter of the here document, including any quotes),
+
+=item [5]
+
+"This is the message.\n" (i.e. the text of the here document),
+
+=item [6]
+
+"EOMSG" (i.e. the right delimiter of the here document),
+
+=item [7..10]
+
+"" (a here document has no second left delimiter, second text, second right
+delimiter, or trailing modifiers).
+
+=back
+
+However, the matching position of the input variable would be set to
+"exit;" (i.e. I<after> the closing delimiter of the here document),
+which would cause the earlier " || die;\nexit;" to be skipped in any
+sequence of code fragment extractions.
+
+To avoid this problem, when it encounters a here document whilst
+extracting from a modifiable string, C<extract_quotelike> silently
+rearranges the string to an equivalent piece of Perl:
+
+ <<'EOMSG'
+ This is the message.
+ EOMSG
+ || die;
+ exit;
+
+in which the here document I<is> contiguous. It still leaves the
+matching position after the here document, but now the rest of the line
+on which the here document starts is not skipped.
+
+To prevent <extract_quotelike> from mucking about with the input in this way
+(this is the only case where a list-context C<extract_quotelike> does so),
+you can pass the input variable as an interpolated literal:
+
+ $quotelike = extract_quotelike("$var");
+
+
+=head2 C<extract_codeblock>
+
+C<extract_codeblock> attempts to recognize and extract a balanced
+bracket delimited substring that may contain unbalanced brackets
+inside Perl quotes or quotelike operations. That is, C<extract_codeblock>
+is like a combination of C<"extract_bracketed"> and
+C<"extract_quotelike">.
+
+C<extract_codeblock> takes the same initial three parameters as C<extract_bracketed>:
+a text to process, a set of delimiter brackets to look for, and a prefix to
+match first. It also takes an optional fourth parameter, which allows the
+outermost delimiter brackets to be specified separately (see below).
+
+Omitting the first argument (input text) means process C<$_> instead.
+Omitting the second argument (delimiter brackets) indicates that only C<'{'> is to be used.
+Omitting the third argument (prefix argument) implies optional whitespace at the start.
+Omitting the fourth argument (outermost delimiter brackets) indicates that the
+value of the second argument is to be used for the outermost delimiters.
+
+Once the prefix an dthe outermost opening delimiter bracket have been
+recognized, code blocks are extracted by stepping through the input text and
+trying the following alternatives in sequence:
+
+=over 4
+
+=item 1.
+
+Try and match a closing delimiter bracket. If the bracket was the same
+species as the last opening bracket, return the substring to that
+point. If the bracket was mismatched, return an error.
+
+=item 2.
+
+Try to match a quote or quotelike operator. If found, call
+C<extract_quotelike> to eat it. If C<extract_quotelike> fails, return
+the error it returned. Otherwise go back to step 1.
+
+=item 3.
+
+Try to match an opening delimiter bracket. If found, call
+C<extract_codeblock> recursively to eat the embedded block. If the
+recursive call fails, return an error. Otherwise, go back to step 1.
+
+=item 4.
+
+Unconditionally match a bareword or any other single character, and
+then go back to step 1.
+
+=back
+
+
+Examples:
+
+ # Find a while loop in the text
+
+ if ($text =~ s/.*?while\s*\{/{/)
+ {
+ $loop = "while " . extract_codeblock($text);
+ }
+
+ # Remove the first round-bracketed list (which may include
+ # round- or curly-bracketed code blocks or quotelike operators)
+
+ extract_codeblock $text, "(){}", '[^(]*';
+
+
+The ability to specify a different outermost delimiter bracket is useful
+in some circumstances. For example, in the Parse::RecDescent module,
+parser actions which are to be performed only on a successful parse
+are specified using a C<E<lt>defer:...E<gt>> directive. For example:
+
+ sentence: subject verb object
+ <defer: {$::theVerb = $item{verb}} >
+
+Parse::RecDescent uses C<extract_codeblock($text, '{}E<lt>E<gt>')> to extract the code
+within the C<E<lt>defer:...E<gt>> directive, but there's a problem.
+
+A deferred action like this:
+
+ <defer: {if ($count>10) {$count--}} >
+
+will be incorrectly parsed as:
+
+ <defer: {if ($count>
+
+because the "less than" operator is interpreted as a closing delimiter.
+
+But, by extracting the directive using
+S<C<extract_codeblock($text, '{}', undef, 'E<lt>E<gt>')>>
+the '>' character is only treated as a delimited at the outermost
+level of the code block, so the directive is parsed correctly.
+
+=head2 C<extract_multiple>
+
+The C<extract_multiple> subroutine takes a string to be processed and a
+list of extractors (subroutines or regular expressions) to apply to that string.
+
+In an array context C<extract_multiple> returns an array of substrings
+of the original string, as extracted by the specified extractors.
+In a scalar context, C<extract_multiple> returns the first
+substring successfully extracted from the original string. In both
+scalar and void contexts the original string has the first successfully
+extracted substring removed from it. In all contexts
+C<extract_multiple> starts at the current C<pos> of the string, and
+sets that C<pos> appropriately after it matches.
+
+Hence, the aim of of a call to C<extract_multiple> in a list context
+is to split the processed string into as many non-overlapping fields as
+possible, by repeatedly applying each of the specified extractors
+to the remainder of the string. Thus C<extract_multiple> is
+a generalized form of Perl's C<split> subroutine.
+
+The subroutine takes up to four optional arguments:
+
+=over 4
+
+=item 1.
+
+A string to be processed (C<$_> if the string is omitted or C<undef>)
+
+=item 2.
+
+A reference to a list of subroutine references and/or qr// objects and/or
+literal strings and/or hash references, specifying the extractors
+to be used to split the string. If this argument is omitted (or
+C<undef>) the list:
+
+ [
+ sub { extract_variable($_[0], '') },
+ sub { extract_quotelike($_[0],'') },
+ sub { extract_codeblock($_[0],'{}','') },
+ ]
+
+is used.
+
+
+=item 3.
+
+An number specifying the maximum number of fields to return. If this
+argument is omitted (or C<undef>), split continues as long as possible.
+
+If the third argument is I<N>, then extraction continues until I<N> fields
+have been successfully extracted, or until the string has been completely
+processed.
+
+Note that in scalar and void contexts the value of this argument is
+automatically reset to 1 (under C<-w>, a warning is issued if the argument
+has to be reset).
+
+=item 4.
+
+A value indicating whether unmatched substrings (see below) within the
+text should be skipped or returned as fields. If the value is true,
+such substrings are skipped. Otherwise, they are returned.
+
+=back
+
+The extraction process works by applying each extractor in
+sequence to the text string. If the extractor is a subroutine it
+is called in a list
+context and is expected to return a list of a single element, namely
+the extracted text.
+Note that the value returned by an extractor subroutine need not bear any
+relationship to the corresponding substring of the original text (see
+examples below).
+
+If the extractor is a precompiled regular expression or a string,
+it is matched against the text in a scalar context with a leading
+'\G' and the gc modifiers enabled. The extracted value is either
+$1 if that variable is defined after the match, or else the
+complete match (i.e. $&).
+
+If the extractor is a hash reference, it must contain exactly one element.
+The value of that element is one of the
+above extractor types (subroutine reference, regular expression, or string).
+The key of that element is the name of a class into which the successful
+return value of the extractor will be blessed.
+
+If an extractor returns a defined value, that value is immediately
+treated as the next extracted field and pushed onto the list of fields.
+If the extractor was specified in a hash reference, the field is also
+blessed into the appropriate class,
+
+If the extractor fails to match (in the case of a regex extractor), or returns an empty list or an undefined value (in the case of a subroutine extractor), it is
+assumed to have failed to extract.
+If none of the extractor subroutines succeeds, then one
+character is extracted from the start of the text and the extraction
+subroutines reapplied. Characters which are thus removed are accumulated and
+eventually become the next field (unless the fourth argument is true, in which
+case they are disgarded).
+
+For example, the following extracts substrings that are valid Perl variables:
+
+ @fields = extract_multiple($text,
+ [ sub { extract_variable($_[0]) } ],
+ undef, 1);
+
+This example separates a text into fields which are quote delimited,
+curly bracketed, and anything else. The delimited and bracketed
+parts are also blessed to identify them (the "anything else" is unblessed):
+
+ @fields = extract_multiple($text,
+ [
+ { Delim => sub { extract_delimited($_[0],q{'"}) } },
+ { Brack => sub { extract_bracketed($_[0],'{}') } },
+ ]);
+
+This call extracts the next single substring that is a valid Perl quotelike
+operator (and removes it from $text):
+
+ $quotelike = extract_multiple($text,
+ [
+ sub { extract_quotelike($_[0]) },
+ ], undef, 1);
+
+Finally, here is yet another way to do comma-separated value parsing:
+
+ @fields = extract_multiple($csv_text,
+ [
+ sub { extract_delimited($_[0],q{'"}) },
+ qr/([^,]+)(.*)/,
+ ],
+ undef,1);
+
+The list in the second argument means:
+I<"Try and extract a ' or " delimited string, otherwise extract anything up to a comma...">.
+The undef third argument means:
+I<"...as many times as possible...">,
+and the true value in the fourth argument means
+I<"...discarding anything else that appears (i.e. the commas)">.
+
+If you wanted the commas preserved as separate fields (i.e. like split
+does if your split pattern has capturing parentheses), you would
+just make the last parameter undefined (or remove it).
+
+
+=head2 C<gen_delimited_pat>
+
+The C<gen_delimited_pat> subroutine takes a single (string) argument and
+builds a Friedl-style optimized regex that matches a string delimited
+by any one of the characters in the single argument. For example:
+
+ gen_delimited_pat(q{'"})
+
+returns the regex:
+
+ (?:\"(?:\\\"|(?!\").)*\"|\'(?:\\\'|(?!\').)*\')
+
+Note that the specified delimiters are automatically quotemeta'd.
+
+A typical use of C<gen_delimited_pat> would be to build special purpose tags
+for C<extract_tagged>. For example, to properly ignore "empty" XML elements
+(which might contain quoted strings):
+
+ my $empty_tag = '<(' . gen_delimited_pat(q{'"}) . '|.)+/>';
+
+ extract_tagged($text, undef, undef, undef, {ignore => [$empty_tag]} );
+
+
+C<gen_delimited_pat> may also be called with an optional second argument,
+which specifies the "escape" character(s) to be used for each delimiter.
+For example to match a Pascal-style string (where ' is the delimiter
+and '' is a literal ' within the string):
+
+ gen_delimited_pat(q{'},q{'});
+
+Different escape characters can be specified for different delimiters.
+For example, to specify that '/' is the escape for single quotes
+and '%' is the escape for double quotes:
+
+ gen_delimited_pat(q{'"},q{/%});
+
+If more delimiters than escape chars are specified, the last escape char
+is used for the remaining delimiters.
+If no escape char is specified for a given specified delimiter, '\' is used.
+
+Note that
+C<gen_delimited_pat> was previously called
+C<delimited_pat>. That name may still be used, but is now deprecated.
+
+
+=head1 DIAGNOSTICS
+
+In a list context, all the functions return C<(undef,$original_text)>
+on failure. In a scalar context, failure is indicated by returning C<undef>
+(in this case the input text is not modified in any way).
+
+In addition, on failure in I<any> context, the C<$@> variable is set.
+Accessing C<$@-E<gt>{error}> returns one of the error diagnostics listed
+below.
+Accessing C<$@-E<gt>{pos}> returns the offset into the original string at
+which the error was detected (although not necessarily where it occurred!)
+Printing C<$@> directly produces the error message, with the offset appended.
+On success, the C<$@> variable is guaranteed to be C<undef>.
+
+The available diagnostics are:
+
+=over 4
+
+=item C<Did not find a suitable bracket: "%s">
+
+The delimiter provided to C<extract_bracketed> was not one of
+C<'()[]E<lt>E<gt>{}'>.
+
+=item C<Did not find prefix: /%s/>
+
+A non-optional prefix was specified but wasn't found at the start of the text.
+
+=item C<Did not find opening bracket after prefix: "%s">
+
+C<extract_bracketed> or C<extract_codeblock> was expecting a
+particular kind of bracket at the start of the text, and didn't find it.
+
+=item C<No quotelike operator found after prefix: "%s">
+
+C<extract_quotelike> didn't find one of the quotelike operators C<q>,
+C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y> at the start of the substring
+it was extracting.
+
+=item C<Unmatched closing bracket: "%c">
+
+C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> encountered
+a closing bracket where none was expected.
+
+=item C<Unmatched opening bracket(s): "%s">
+
+C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> ran
+out of characters in the text before closing one or more levels of nested
+brackets.
+
+=item C<Unmatched embedded quote (%s)>
+
+C<extract_bracketed> attempted to match an embedded quoted substring, but
+failed to find a closing quote to match it.
+
+=item C<Did not find closing delimiter to match '%s'>
+
+C<extract_quotelike> was unable to find a closing delimiter to match the
+one that opened the quote-like operation.
+
+=item C<Mismatched closing bracket: expected "%c" but found "%s">
+
+C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> found
+a valid bracket delimiter, but it was the wrong species. This usually
+indicates a nesting error, but may indicate incorrect quoting or escaping.
+
+=item C<No block delimiter found after quotelike "%s">
+
+C<extract_quotelike> or C<extract_codeblock> found one of the
+quotelike operators C<q>, C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y>
+without a suitable block after it.
+
+=item C<Did not find leading dereferencer>
+
+C<extract_variable> was expecting one of '$', '@', or '%' at the start of
+a variable, but didn't find any of them.
+
+=item C<Bad identifier after dereferencer>
+
+C<extract_variable> found a '$', '@', or '%' indicating a variable, but that
+character was not followed by a legal Perl identifier.
+
+=item C<Did not find expected opening bracket at %s>
+
+C<extract_codeblock> failed to find any of the outermost opening brackets
+that were specified.
+
+=item C<Improperly nested codeblock at %s>
+
+A nested code block was found that started with a delimiter that was specified
+as being only to be used as an outermost bracket.
+
+=item C<Missing second block for quotelike "%s">
+
+C<extract_codeblock> or C<extract_quotelike> found one of the
+quotelike operators C<s>, C<tr> or C<y> followed by only one block.
+
+=item C<No match found for opening bracket>
+
+C<extract_codeblock> failed to find a closing bracket to match the outermost
+opening bracket.
+
+=item C<Did not find opening tag: /%s/>
+
+C<extract_tagged> did not find a suitable opening tag (after any specified
+prefix was removed).
+
+=item C<Unable to construct closing tag to match: /%s/>
+
+C<extract_tagged> matched the specified opening tag and tried to
+modify the matched text to produce a matching closing tag (because
+none was specified). It failed to generate the closing tag, almost
+certainly because the opening tag did not start with a
+bracket of some kind.
+
+=item C<Found invalid nested tag: %s>
+
+C<extract_tagged> found a nested tag that appeared in the "reject" list
+(and the failure mode was not "MAX" or "PARA").
+
+=item C<Found unbalanced nested tag: %s>
+
+C<extract_tagged> found a nested opening tag that was not matched by a
+corresponding nested closing tag (and the failure mode was not "MAX" or "PARA").
+
+=item C<Did not find closing tag>
+
+C<extract_tagged> reached the end of the text without finding a closing tag
+to match the original opening tag (and the failure mode was not
+"MAX" or "PARA").
+
+
+
+
+=back
+
+
+=head1 AUTHOR
+
+Damian Conway ([email protected])
+
+
+=head1 BUGS AND IRRITATIONS
+
+There are undoubtedly serious bugs lurking somewhere in this code, if
+only because parts of it give the impression of understanding a great deal
+more about Perl than they really do.
+
+Bug reports and other feedback are most welcome.
+
+
+=head1 COPYRIGHT
+
+ Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Class/ISA/test.pl#1 (text) ====
Index: perl/macos/bundled_lib/t/Class/ISA/test.pl
--- perl/macos/bundled_lib/t/Class/ISA/test.pl.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Class/ISA/test.pl Fri Jul 20 12:30:05 2001
@@ -0,0 +1,40 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..2\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Class::ISA;
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# Insert your test code below (better if it prints "ok 13"
+# (correspondingly "not ok 13") depending on the success of chunk 13
+# of the test code):
+
+ @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
+ @Food::Fish::ISA = qw(Food);
+ @Food::ISA = qw(Matter);
+ @Life::Fungus::ISA = qw(Life);
+ @Chemicals::ISA = qw(Matter);
+ @Life::ISA = qw(Matter);
+ @Matter::ISA = qw();
+
+ use Class::ISA;
+ my @path = Class::ISA::super_path('Food::Fishstick');
+ my $flat_path = join ' ', @path;
+ print "# Food::Fishstick path is:\n# $flat_path\n";
+ print "not " unless
+ "Food::Fish Food Matter Life::Fungus Life Chemicals" eq $flat_path;
+ print "ok 2\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Digest/Digest.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Digest/Digest.t
--- perl/macos/bundled_lib/t/Digest/Digest.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Digest/Digest.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,26 @@
+print "1..3\n";
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Digest;
+
+my $hexdigest = "900150983cd24fb0d6963f7d28e17f72";
+if (ord('A') == 193) { # EBCDIC
+ $hexdigest = "fe4ea0d98f9cd8d1d27f102a93cb0bb0"; # IBM-1047
+}
+
+print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest;
+print "ok 1\n";
+
+print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest;
+print "ok 2\n";
+
+eval {
+ print "not " unless Digest->new("HMAC-MD5" => "Jefe")->add("what do ya want for nothing?")->hexdigest eq "750c783e6ab0b503eaa86e310a5db738";
+ print "ok 3\n";
+};
+print "ok 3\n" if $@ && $@ =~ /^Can't locate/;
+
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/test.pl#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/test.pl
--- perl/macos/bundled_lib/t/Filter/Simple/test.pl.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Filter/Simple/test.pl Fri Jul 20 12:30:05 2001
@@ -0,0 +1,27 @@
+#!./perl
+
+BEGIN {
+ chdir('t') if -d 't';
+ @INC = 'lib';
+}
+
+print "1..6\n";
+
+use MyFilter qr/not ok/ => "ok", fail => "ok";
+
+sub fail { print "fail ", $_[0], "\n" }
+
+print "not ok 1\n";
+print "fail 2\n";
+
+fail(3);
+&fail(4);
+
+print "not " unless "whatnot okapi" eq "whatokapi";
+print "ok 5\n";
+
+no MyFilter;
+
+print "not " unless "not ok" =~ /^not /;
+print "ok 6\n";
+
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Switch/test.pl#1 (text) ====
Index: perl/macos/bundled_lib/t/Switch/test.pl
--- perl/macos/bundled_lib/t/Switch/test.pl.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Switch/test.pl Fri Jul 20 12:30:05 2001
@@ -0,0 +1,277 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Carp;
+use Switch qw(__ fallthrough);
+
+my($C,$M);sub ok{$C++;$M.=$_[0]?"ok $C\n":"not ok $C (line ".(caller)[2].")\n"}
+END{print"1..$C\n$M"}
+
+# NON-case THINGS;
+
+$case->{case} = { case => "case" };
+
+*case = \&case;
+
+# PREMATURE case
+
+eval { case 1 { ok(0) }; ok(0) } || ok(1);
+
+# H.O. FUNCS
+
+switch (__ > 2) {
+
+ case 1 { ok(0) } else { ok(1) }
+ case 2 { ok(0) } else { ok(1) }
+ case 3 { ok(1) } else { ok(0) }
+}
+
+switch (3) {
+
+ eval { case __ <= 1 || __ > 2 { ok(0) } } || ok(1);
+ case __ <= 2 { ok(0) };
+ case __ <= 3 { ok(1) };
+}
+
+# POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE
+
+# 1. NUMERIC SWITCH
+
+for (1..3)
+{
+ switch ($_) {
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($_==1) } else { ok($_!=1) }
+ case 1 { ok ($_==1) } else { ok($_!=1) }
+ case (3) { ok ($_==3) } else { ok($_!=3) }
+ case (4) { ok (0) } else { ok(1) }
+ case (2) { ok ($_==2) } else { ok($_!=2) }
+
+ # STRING
+ case ('a') { ok (0) } else { ok(1) }
+ case 'a' { ok (0) } else { ok(1) }
+ case ('3') { ok ($_ == 3) } else { ok($_ != 3) }
+ case ('3.0') { ok (0) } else { ok(1) }
+
+ # ARRAY
+ case ([10,5,1]) { ok ($_==1) } else { ok($_!=1) }
+ case [10,5,1] { ok ($_==1) } else { ok($_!=1) }
+ case (['a','b']) { ok (0) } else { ok(1) }
+ case (['a','b',3]) { ok ($_==3) } else { ok ($_!=3) }
+ case (['a','b',2.0]) { ok ($_==2) } else { ok ($_!=2) }
+ case ([]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case {} { ok (0) } else { ok (1) }
+ case {1,1} { ok ($_==1) } else { ok($_!=1) }
+ case ({1=>1, 2=>0}) { ok ($_==1) } else { ok($_!=1) }
+
+ # SUB/BLOCK
+ case (sub {$_[0]==2}) { ok ($_==2) } else { ok($_!=2) }
+ case {$_[0]==2} { ok ($_==2) } else { ok($_!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# 2. STRING SWITCH
+
+for ('a'..'c','1')
+{
+ switch ($_) {
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
+ case (1.0) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
+
+ # STRING
+ case ('a') { ok ($_ eq 'a') } else { ok($_ ne 'a') }
+ case ('b') { ok ($_ eq 'b') } else { ok($_ ne 'b') }
+ case ('c') { ok ($_ eq 'c') } else { ok($_ ne 'c') }
+ case ('1') { ok ($_ eq '1') } else { ok($_ ne '1') }
+ case ('d') { ok (0) } else { ok (1) }
+
+ # ARRAY
+ case (['a','1']) { ok ($_ eq 'a' || $_ eq '1') }
+ else { ok ($_ ne 'a' && $_ ne '1') }
+ case (['z','2']) { ok (0) } else { ok(1) }
+ case ([]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($_ eq 'a' || $_ eq '1') }
+ else { ok ($_ ne 'a' && $_ ne '1') }
+
+ # SUB/BLOCK
+ case (sub{$_[0] eq 'a' }) { ok ($_ eq 'a') }
+ else { ok($_ ne 'a') }
+ case {$_[0] eq 'a'} { ok ($_ eq 'a') } else { ok($_ ne 'a') }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# 3. ARRAY SWITCH
+
+my $iteration = 0;
+for ([],[1,'a'],[2,'b'])
+{
+ switch ($_) {
+ $iteration++;
+ # SELF
+ case ($_) { ok(1) }
+
+ # NUMERIC
+ case (1) { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case (1.0) { ok ($iteration==2) } else { ok ($iteration!=2) }
+
+ # STRING
+ case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case ('b') { ok ($iteration==3) } else { ok ($iteration!=3) }
+ case ('1') { ok ($iteration==2) } else { ok ($iteration!=2) }
+
+ # ARRAY
+ case (['a',2]) { ok ($iteration>=2) } else { ok ($iteration<2) }
+ case ([1,'a']) { ok ($iteration==2) } else { ok($iteration!=2) }
+ case ([]) { ok (0) } else { ok(1) }
+ case ([7..100]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+
+ # SUB/BLOCK
+ case {scalar grep /a/, @_} { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (sub {scalar grep /a/, @_ }) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# 4. HASH SWITCH
+
+$iteration = 0;
+for ({},{a=>1,b=>0})
+{
+ switch ($_) {
+ $iteration++;
+
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok (0) } else { ok (1) }
+ case (1.0) { ok (0) } else { ok (1) }
+
+ # STRING
+ case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case ('b') { ok (0) } else { ok (1) }
+ case ('c') { ok (0) } else { ok (1) }
+
+ # ARRAY
+ case (['a',2]) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (['b','a']) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (['b','c']) { ok (0) } else { ok (1) }
+ case ([]) { ok (0) } else { ok(1) }
+ case ([7..100]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok (0) } else { ok (1) }
+
+ # SUB/BLOCK
+ case {$_[0]{a}} { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (sub {$_[0]{a}}) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# 5. CODE SWITCH
+
+$iteration = 0;
+for ( sub {1},
+ sub { return 0 unless @_;
+ my ($data) = @_;
+ my $type = ref $data;
+ return $type eq 'HASH' && $data->{a}
+ || $type eq 'Regexp' && 'a' =~ /$data/
+ || $type eq "" && $data eq '1';
+ },
+ sub {0} )
+{
+ switch ($_) {
+ $iteration++;
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($iteration<=2) } else { ok ($iteration>2) }
+ case (1.0) { ok ($iteration<=2) } else { ok ($iteration>2) }
+ case (1.1) { ok ($iteration==1) } else { ok ($iteration!=1) }
+
+ # STRING
+ case ('a') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('b') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('c') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('1') { ok ($iteration<=2) } else { ok ($iteration>2) }
+
+ # ARRAY
+ case ([1, 'a']) { ok ($iteration<=2) }
+ else { ok ($iteration>2) }
+ case (['b','a']) { ok ($iteration==1) }
+ else { ok ($iteration!=1) }
+ case (['b','c']) { ok ($iteration==1) }
+ else { ok ($iteration!=1) }
+ case ([]) { ok ($iteration==1) } else { ok($iteration!=1) }
+ case ([7..100]) { ok ($iteration==1) }
+ else { ok($iteration!=1) }
+
+ # HASH
+ case ({}) { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration<=2) }
+ else { ok ($iteration>2) }
+
+ # SUB/BLOCK
+ case {$_[0]->{a}} { ok (0) } else { ok (1) }
+ case (sub {$_[0]{a}}) { ok (0) } else { ok (1) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# NESTED SWITCHES
+
+for my $count (1..3)
+{
+ switch ([9,"a",11]) {
+ case (qr/\d/) {
+ switch ($count) {
+ case (1) { ok($count==1) }
+ else { ok($count!=1) }
+ case ([5,6]) { ok(0) } else { ok(1) }
+ }
+ }
+ ok(1) case (11);
+ }
+}
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/genxt.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/genxt.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/genxt.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Text/Balanced/t/genxt.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,104 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..35\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Text::Balanced qw ( gen_extract_tagged );
+$loaded = 1;
+print "ok 1\n";
+$count=2;
+use vars qw( $DEBUG );
+sub debug { print "\t>>>",@_ if $DEBUG }
+
+######################### End of black magic.
+
+
+$cmd = "print";
+$neg = 0;
+while (defined($str = <DATA>))
+{
+ chomp $str;
+ $str =~ s/\\n/\n/g;
+ if ($str =~ s/\A# USING://)
+ {
+ $neg = 0;
+ eval{local$^W;*f = eval $str || die};
+ next;
+ }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ my @res;
+ $var = eval { @res = f($str) };
+ debug "\t list got: [" . join("|",@res) . "]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval { scalar f($str) };
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+}
+
+__DATA__
+
+# USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]});
+ <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
+
+# USING: gen_extract_tagged("BEGIN","END");
+ BEGIN at the BEGIN keyword and END at the END;
+ BEGIN at the beginning and end at the END;
+
+# USING: gen_extract_tagged(undef,undef,undef,{ignore=>["<[^>]*/>"]});
+ <A>aaa<B>bbb<BR/>ccc</B>ddd</A>;
+
+# USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"MAX"});
+ ; at the ;-) keyword
+
+# USING: gen_extract_tagged("<[A-Z]+>",undef, undef, {ignore=>["<BR>"]});
+ <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
+
+# THESE SHOULD FAIL
+ BEGIN at the beginning and end at the end;
+ BEGIN at the BEGIN keyword and END at the end;
+
+# TEST EXTRACTION OF TAGGED STRINGS
+# USING: gen_extract_tagged("BEGIN","END",undef,{reject=>["BEGIN","END"]});
+# THESE SHOULD FAIL
+ BEGIN at the BEGIN keyword and END at the end;
+
+# USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"PARA"});
+ ; at the ;-) keyword
+
+
+# USING: gen_extract_tagged();
+ <A>some text</A>;
+ <B>some text<A>other text</A></B>;
+ <A>some text<A>other text</A></A>;
+ <A HREF="#section2">some text</A>;
+
+# THESE SHOULD FAIL
+ <A>some text
+ <A>some text<A>other text</A>;
+ <B>some text<A>other text</B>;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xbrak.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/xbrak.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/xbrak.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Text/Balanced/t/xbrak.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,81 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..19\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Text::Balanced qw ( extract_bracketed );
+$loaded = 1;
+print "ok 1\n";
+$count=2;
+use vars qw( $DEBUG );
+sub debug { print "\t>>>",@_ if $DEBUG }
+
+######################### End of black magic.
+
+
+$cmd = "print";
+$neg = 0;
+while (defined($str = <DATA>))
+{
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ $var = eval "() = $cmd";
+ debug "\t list got: [$var]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str),1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+}
+
+__DATA__
+
+# USING: extract_bracketed($str);
+{a nested { and } are okay as are () and <> pairs and escaped \}'s };
+{a nested\n{ and } are okay as are\n() and <> pairs and escaped \}'s };
+
+# USING: extract_bracketed($str,'{}');
+{a nested { and } are okay as are unbalanced ( and < pairs and escaped \}'s };
+
+# THESE SHOULD FAIL
+{an unmatched nested { isn't okay, nor are ( and < };
+{an unbalanced nested [ even with } and ] to match them;
+
+
+# USING: extract_bracketed($str,'<"`q>');
+<a q{uoted} ">" unbalanced right bracket of /(q>)/ either sort (`>>>""">>>>`) is okay >;
+
+# USING: extract_bracketed($str,'<">');
+<a quoted ">" unbalanced right bracket is okay >;
+
+# USING: extract_bracketed($str,'<"`>');
+<a quoted ">" unbalanced right bracket of either sort (`>>>""">>>>`) is okay >;
+
+# THIS SHOULD FAIL
+<a misquoted '>' unbalanced right bracket is bad >;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xcode.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/xcode.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/xcode.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Text/Balanced/t/xcode.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,94 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..37\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Text::Balanced qw ( extract_codeblock );
+$loaded = 1;
+print "ok 1\n";
+$count=2;
+use vars qw( $DEBUG );
+sub debug { print "\t>>>",@_ if $DEBUG }
+
+######################### End of black magic.
+
+
+$cmd = "print";
+$neg = 0;
+while (defined($str = <DATA>))
+{
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ my @res;
+ $var = eval "\@res = $cmd";
+ debug "\t Failed: $@ at " . $@+0 .")" if $@;
+ debug "\t list got: [" . join("|",@res) . "]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+}
+
+__DATA__
+
+# USING: extract_codeblock($str,'<>');
+< %x = ( try => "this") >;
+< %x = () >;
+< %x = ( $try->{this}, "too") >;
+< %'x = ( $try->{this}, "too") >;
+< %'x'y = ( $try->{this}, "too") >;
+< %::x::y = ( $try->{this}, "too") >;
+
+# THIS SHOULD FAIL
+< %x = do { $try > 10 } >;
+
+# USING: extract_codeblock($str);
+
+{ $a = /\}/; };
+{ sub { $_[0] /= $_[1] } }; # / here
+{ 1; };
+{ $a = 1; };
+
+
+# USING: extract_codeblock($str,undef,'=*');
+========{$a=1};
+
+# USING: extract_codeblock($str,'{}<>');
+< %x = do { $try > 10 } >;
+
+# USING: extract_codeblock($str,'{}',undef,'<>');
+< %x = do { $try > 10 } >;
+
+# USING: extract_codeblock($str,'{}');
+{ $a = $b; # what's this doing here? \n };'
+{ $a = $b; \n $a =~ /$b/; \n @a = map /\s/ @b };
+
+# THIS SHOULD FAIL
+{ $a = $b; # what's this doing here? };'
+{ $a = $b; # what's this doing here? ;'
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xdeli.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/xdeli.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/xdeli.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Text/Balanced/t/xdeli.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,95 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..45\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Text::Balanced qw ( extract_delimited );
+$loaded = 1;
+print "ok 1\n";
+$count=2;
+use vars qw( $DEBUG );
+sub debug { print "\t>>>",@_ if $DEBUG }
+
+######################### End of black magic.
+
+
+$cmd = "print";
+$neg = 0;
+while (defined($str = <DATA>))
+{
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ $var = eval "() = $cmd";
+ debug "\t list got: [$var]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+}
+
+__DATA__
+# USING: extract_delimited($str,'/#$',undef,'/#$');
+/a/;
+/a///;
+#b#;
+#b###;
+$c$;
+$c$$$;
+
+# TEST EXTRACTION OF DELIMITED TEXT WITH ESCAPES
+# USING: extract_delimited($str,'/#$',undef,'\\');
+/a/;
+/a\//;
+#b#;
+#b\##;
+$c$;
+$c\$$;
+
+# TEST EXTRACTION OF DELIMITED TEXT
+# USING: extract_delimited($str);
+'a';
+"b";
+`c`;
+'a\'';
+'a\\';
+'\\a';
+"a\\";
+"\\a";
+"b\'\"\'";
+`c '\`abc\`'`;
+
+# TEST EXTRACTION OF DELIMITED TEXT
+# USING: extract_delimited($str,'/#$','-->');
+-->/a/;
+-->#b#;
+-->$c$;
+
+# THIS SHOULD FAIL
+$c$;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xmult.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/xmult.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/xmult.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Text/Balanced/t/xmult.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,316 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..85\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Text::Balanced qw ( :ALL );
+$loaded = 1;
+print "ok 1\n";
+$count=2;
+use vars qw( $DEBUG );
+sub debug { print "\t>>>",@_ if $DEBUG }
+
+######################### End of black magic.
+
+sub expect
+{
+ local $^W;
+ my ($l1, $l2) = @_;
+
+ if (@$l1 != @$l2)
+ {
+ print "\@l1: ", join(", ", @$l1), "\n";
+ print "\@l2: ", join(", ", @$l2), "\n";
+ print "not ";
+ }
+ else
+ {
+ for (my $i = 0; $i < @$l1; $i++)
+ {
+ if ($l1->[$i] ne $l2->[$i])
+ {
+ print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n";
+ print "not ";
+ last;
+ }
+ }
+ }
+
+ print "ok $count\n";
+ $count++;
+}
+
+sub divide
+{
+ my ($text, @index) = @_;
+ my @bits = ();
+ unshift @index, 0;
+ push @index, length($text);
+ for ( my $i= 0; $i < $#index; $i++)
+ {
+ push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]);
+ }
+ pop @bits;
+ return @bits;
+
+}
+
+
+$stdtext1 = q{$var = do {"val" && $val;};};
+
+# TESTS 2-4
+$text = $stdtext1;
+expect [ extract_multiple($text,undef,1) ],
+ [ divide $stdtext1 => 4 ];
+
+expect [ pos $text], [ 4 ];
+expect [ $text ], [ $stdtext1 ];
+
+# TESTS 5-7
+$text = $stdtext1;
+expect [ scalar extract_multiple($text,undef,1) ],
+ [ divide $stdtext1 => 4 ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext1,4) ];
+
+
+# TESTS 8-10
+$text = $stdtext1;
+expect [ extract_multiple($text,undef,2) ],
+ [ divide($stdtext1 => 4, 10) ];
+
+expect [ pos $text], [ 10 ];
+expect [ $text ], [ $stdtext1 ];
+
+# TESTS 11-13
+$text = $stdtext1;
+expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ],
+ [ substr($stdtext1,0,4) ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext1,4) ];
+
+
+# TESTS 14-16
+$text = $stdtext1;
+expect [ extract_multiple($text,undef,3) ],
+ [ divide($stdtext1 => 4, 10, 26) ];
+
+expect [ pos $text], [ 26 ];
+expect [ $text ], [ $stdtext1 ];
+
+# TESTS 17-19
+$text = $stdtext1;
+expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ],
+ [ substr($stdtext1,0,4) ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext1,4) ];
+
+
+# TESTS 20-22
+$text = $stdtext1;
+expect [ extract_multiple($text,undef,4) ],
+ [ divide($stdtext1 => 4, 10, 26, 27) ];
+
+expect [ pos $text], [ 27 ];
+expect [ $text ], [ $stdtext1 ];
+
+# TESTS 23-25
+$text = $stdtext1;
+expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ],
+ [ substr($stdtext1,0,4) ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext1,4) ];
+
+
+# TESTS 26-28
+$text = $stdtext1;
+expect [ extract_multiple($text,undef,5) ],
+ [ divide($stdtext1 => 4, 10, 26, 27) ];
+
+expect [ pos $text], [ 27 ];
+expect [ $text ], [ $stdtext1 ];
+
+
+# TESTS 29-31
+$text = $stdtext1;
+expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ],
+ [ substr($stdtext1,0,4) ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext1,4) ];
+
+
+
+# TESTS 32-34
+$stdtext2 = q{$var = "val" && (1,2,3);};
+
+$text = $stdtext2;
+expect [ extract_multiple($text) ],
+ [ divide($stdtext2 => 4, 7, 12, 24) ];
+
+expect [ pos $text], [ 24 ];
+expect [ $text ], [ $stdtext2 ];
+
+# TESTS 35-37
+$text = $stdtext2;
+expect [ scalar extract_multiple($text) ],
+ [ substr($stdtext2,0,4) ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext2,4) ];
+
+
+# TESTS 38-40
+$text = $stdtext2;
+expect [ extract_multiple($text,[\&extract_bracketed]) ],
+ [ substr($stdtext2,0,15), substr($stdtext2,16,7), substr($stdtext2,23) ];
+
+expect [ pos $text], [ 24 ];
+expect [ $text ], [ $stdtext2 ];
+
+# TESTS 41-43
+$text = $stdtext2;
+expect [ scalar extract_multiple($text,[\&extract_bracketed]) ],
+ [ substr($stdtext2,0,15) ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext2,15) ];
+
+
+# TESTS 44-46
+$text = $stdtext2;
+expect [ extract_multiple($text,[\&extract_variable]) ],
+ [ substr($stdtext2,0,4), substr($stdtext2,4) ];
+
+expect [ pos $text], [ length($text) ];
+expect [ $text ], [ $stdtext2 ];
+
+# TESTS 47-49
+$text = $stdtext2;
+expect [ scalar extract_multiple($text,[\&extract_variable]) ],
+ [ substr($stdtext2,0,4) ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext2,4) ];
+
+
+# TESTS 50-52
+$text = $stdtext2;
+expect [ extract_multiple($text,[\&extract_quotelike]) ],
+ [ substr($stdtext2,0,6), substr($stdtext2,7,5), substr($stdtext2,12) ];
+
+expect [ pos $text], [ length($text) ];
+expect [ $text ], [ $stdtext2 ];
+
+# TESTS 53-55
+$text = $stdtext2;
+expect [ scalar extract_multiple($text,[\&extract_quotelike]) ],
+ [ substr($stdtext2,0,6) ];
+
+expect [ pos $text], [ 0 ];
+expect [ $text ], [ substr($stdtext2,6) ];
+
+
+# TESTS 56-58
+$text = $stdtext2;
+expect [ extract_multiple($text,[\&extract_quotelike],2,1) ],
+ [ substr($stdtext2,7,5) ];
+
+expect [ pos $text], [ 23 ];
+expect [ $text ], [ $stdtext2 ];
+
+# TESTS 59-61
+$text = $stdtext2;
+expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ],
+ [ substr($stdtext2,7,5) ];
+
+expect [ pos $text], [ 6 ];
+expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ];
+
+
+# TESTS 62-64
+$text = $stdtext2;
+expect [ extract_multiple($text,[\&extract_quotelike],1,1) ],
+ [ substr($stdtext2,7,5) ];
+
+expect [ pos $text], [ 12 ];
+expect [ $text ], [ $stdtext2 ];
+
+# TESTS 65-67
+$text = $stdtext2;
+expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ],
+ [ substr($stdtext2,7,5) ];
+
+expect [ pos $text], [ 6 ];
+expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ];
+
+# TESTS 68-70
+my $stdtext3 = "a,b,c";
+
+$_ = $stdtext3;
+expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ],
+ [ divide($stdtext3 => 1,2,3,4,5) ];
+
+expect [ pos ], [ 5 ];
+expect [ $_ ], [ $stdtext3 ];
+
+# TESTS 71-73
+
+$_ = $stdtext3;
+expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ],
+ [ divide($stdtext3 => 1) ];
+
+expect [ pos ], [ 0 ];
+expect [ $_ ], [ substr($stdtext3,1) ];
+
+
+# TESTS 74-76
+
+$_ = $stdtext3;
+expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ],
+ [ divide($stdtext3 => 1,2,3,4,5) ];
+
+expect [ pos ], [ 5 ];
+expect [ $_ ], [ $stdtext3 ];
+
+# TESTS 77-79
+
+$_ = $stdtext3;
+expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ],
+ [ divide($stdtext3 => 1) ];
+
+expect [ pos ], [ 0 ];
+expect [ $_ ], [ substr($stdtext3,1) ];
+
+
+# TESTS 80-82
+
+$_ = $stdtext3;
+expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ],
+ [ qw(a b c) ];
+
+expect [ pos ], [ 5 ];
+expect [ $_ ], [ $stdtext3 ];
+
+# TESTS 83-85
+
+$_ = $stdtext3;
+expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ],
+ [ divide($stdtext3 => 1) ];
+
+expect [ pos ], [ 0 ];
+expect [ $_ ], [ substr($stdtext3,2) ];
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xquot.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/xquot.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/xquot.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Text/Balanced/t/xquot.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,118 @@
+#!./perl -ws
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..89\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Text::Balanced qw ( extract_quotelike );
+$loaded = 1;
+print "ok 1\n";
+$count=2;
+use vars qw( $DEBUG );
+# $DEBUG=1;
+sub debug { print "\t>>>",@_ if $DEBUG }
+
+######################### End of black magic.
+
+
+$cmd = "print";
+$neg = 0;
+while (defined($str = <DATA>))
+{
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+ $str =~ s/\\n/\n/g;
+ my $orig = $str;
+
+ my @res;
+ eval qq{\@res = $cmd; };
+ debug "\t got:\n" . join "", map { $res[$_]=~s/\n/\\n/g; "\t\t\t$_: [$res[$_]]\n"} (0..$#res);
+ debug "\t left: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy1 = $str)[0];
+ debug "\t pos: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy2 = substr($str,pos($str)))[0] . "...]\n";
+ print "not " if (substr($str,pos($str),1) eq ';')==$neg;
+ print "ok ", $count++;
+ print "\n";
+
+ $str = $orig;
+ debug "\tUsing: scalar $cmd\n";
+ debug "\t on: [$str]\n";
+ $var = eval $cmd;
+ print " ($@)" if $@ && $DEBUG;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: " . (map { s/\n/\\n/g; "[$_]\n" } $var)[0];
+ debug "\t scalar left: " . (map { s/\n/\\n/g; "[$_]\n" } $str)[0];
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print "\n";
+}
+
+__DATA__
+
+# USING: extract_quotelike($str);
+'';
+"";
+"a";
+'b';
+`cc`;
+
+
+<<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
+ <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
+<<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next
+<<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next
+<<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next
+<<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next
+<<" EOHERE"; done() \nline1\nline2\n EOHERE\nand next
+<<""; done()\nline1\nline2\n\n and next
+<<; done()\nline1\nline2\n\n and next
+
+
+"this is a nested $var[$x] {";
+/a/gci;
+m/a/gci;
+
+q(d);
+qq(e);
+qx(f);
+qr(g);
+qw(h i j);
+q{d};
+qq{e};
+qx{f};
+qr{g};
+qq{a nested { and } are okay as are () and <> pairs and escaped \}'s };
+q/slash/;
+q # slash #;
+qr qw qx;
+
+s/x/y/;
+s/x/y/cgimsox;
+s{a}{b};
+s{a}\n {b};
+s(a){b};
+s(a)/b/;
+s/'/\\'/g;
+tr/x/y/;
+y/x/y/;
+
+# THESE SHOULD FAIL
+s<$self->{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->'
+s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->'
+<<EOHERE; done();\nline1\nline2\nEOHERE;\n; next; # RDEL HAS NO ';'
+<<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next; # RDEF HAS NO ';'
+ << EOTHERE; done();\nline1\nline2\n EOTHERE\n; next; # RDEL IS "" (!)
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xtagg.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/xtagg.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/xtagg.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Text/Balanced/t/xtagg.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,118 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..53\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Text::Balanced qw ( extract_tagged gen_extract_tagged );
+$loaded = 1;
+print "ok 1\n";
+$count=2;
+use vars qw( $DEBUG );
+sub debug { print "\t>>>",@_ if $DEBUG }
+
+######################### End of black magic.
+
+
+$cmd = "print";
+$neg = 0;
+while (defined($str = <DATA>))
+{
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ my @res;
+ $var = eval "\@res = $cmd";
+ debug "\t list got: [" . join("|",@res) . "]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+}
+
+__DATA__
+# USING: gen_extract_tagged("BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)")->($str);
+ ignore\n this and then BEGINHERE at the ENDHERE;
+ ignore\n this and then BEGINTHIS at the ENDTHIS;
+
+# USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)");
+ ignore\n this and then BEGINHERE at the ENDHERE;
+ ignore\n this and then BEGINTHIS at the ENDTHIS;
+
+# USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)");
+ ignore\n this and then BEGINHERE at the ENDHERE;
+ ignore\n this and then BEGINTHIS at the ENDTHIS;
+
+# THIS SHOULD FAIL
+ ignore\n this and then BEGINTHIS at the ENDTHAT;
+
+# USING: extract_tagged($str,"BEGIN","END","(?s).*?(?=BEGIN)");
+ ignore\n this and then BEGIN at the END;
+
+# USING: extract_tagged($str);
+ <A-1 HREF="#section2">some text</A-1>;
+
+# USING: extract_tagged($str,qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]});
+ <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
+
+# USING: extract_tagged($str,"BEGIN","END");
+ BEGIN at the BEGIN keyword and END at the END;
+ BEGIN at the beginning and end at the END;
+
+# USING: extract_tagged($str,undef,undef,undef,{ignore=>["<[^>]*/>"]});
+ <A>aaa<B>bbb<BR/>ccc</B>ddd</A>;
+
+# USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"MAX"});
+ ; at the ;-) keyword
+
+# USING: extract_tagged($str,"<[A-Z]+>",undef, undef, {ignore=>["<BR>"]});
+ <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
+
+# THESE SHOULD FAIL
+ BEGIN at the beginning and end at the end;
+ BEGIN at the BEGIN keyword and END at the end;
+
+# TEST EXTRACTION OF TAGGED STRINGS
+# USING: extract_tagged($str,"BEGIN","END",undef,{reject=>["BEGIN","END"]});
+# THESE SHOULD FAIL
+ BEGIN at the BEGIN keyword and END at the end;
+
+# USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"PARA"});
+ ; at the ;-) keyword
+
+
+# USING: extract_tagged($str);
+ <A>some text</A>;
+ <B>some text<A>other text</A></B>;
+ <A>some text<A>other text</A></A>;
+ <A HREF="#section2">some text</A>;
+
+# THESE SHOULD FAIL
+ <A>some text
+ <A>some text<A>other text</A>;
+ <B>some text<A>other text</B>;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/xvari.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/xvari.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/xvari.t.~1~ Fri Jul 20 12:30:05 2001
+++ perl/macos/bundled_lib/t/Text/Balanced/t/xvari.t Fri Jul 20 12:30:05 2001
@@ -0,0 +1,107 @@
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..81\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Text::Balanced qw ( extract_variable );
+$loaded = 1;
+print "ok 1\n";
+$count=2;
+use vars qw( $DEBUG );
+sub debug { print "\t>>>",@_ if $DEBUG }
+
+######################### End of black magic.
+
+
+$cmd = "print";
+$neg = 0;
+while (defined($str = <DATA>))
+{
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ my @res;
+ $var = eval "\@res = $cmd";
+ debug "\t list got: [" . join("|",@res) . "]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+}
+
+__DATA__
+
+# USING: extract_variable($str);
+# THESE SHOULD FAIL
+$a->;
+$a (1..3) { print $a };
+
+# USING: extract_variable($str);
+*var;
+*$var;
+*{var};
+*{$var};
+*var{cat};
+\&var;
+\&mod::var;
+\&mod'var;
+$a;
+$_;
+$a[1];
+$_[1];
+$a{cat};
+$_{cat};
+$a->[1];
+$a->{"cat"}[1];
+@$listref;
+@{$listref};
+$obj->nextval;
+$obj->_nextval;
+$obj->next_val_;
+@{$obj->nextval};
+@{$obj->nextval($cat,$dog)->{new}};
+@{$obj->nextval($cat?$dog:$fish)->{new}};
+@{$obj->nextval(cat()?$dog:$fish)->{new}};
+$ a {'cat'};
+$a::b::c{d}->{$e->()};
+$a'b'c'd{e}->{$e->()};
+$a'b::c'd{e}->{$e->()};
+$#_;
+$#array;
+$#{array};
+$var[$#var];
+
+# THESE SHOULD FAIL
+$a->;
+@{$;
+$ a :: b :: c
+$ a ' b ' c
+
+# USING: extract_variable($str,'=*');
+========$a;
End of Patch.