Add the Filter::Util::Call 1.04 by Paul Marquess from Filter-1.19.
Jarkko Hietaniemi [Wed, 22 Nov 2000 22:45:51 +0000 (22:45 +0000)]
p4raw-id: //depot/perl@7820

MANIFEST
ext/Filter/Util/Call.pm [new file with mode: 0644]
ext/Filter/Util/Call.xs [new file with mode: 0644]
ext/Filter/Util/Makefile.PL [new file with mode: 0644]
t/lib/filt-util.pl [new file with mode: 0644]
t/lib/filt-util.t [new file with mode: 0644]

index 5c25ff6..98e1150 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -287,6 +287,9 @@ ext/File/Glob/Makefile.PL   File::Glob extension makefile writer
 ext/File/Glob/TODO             File::Glob extension todo list
 ext/File/Glob/bsd_glob.c       File::Glob extension run time code
 ext/File/Glob/bsd_glob.h       File::Glob extension header file
+ext/Filter/Util/Call.pm                Filter::Util::Call extension module
+ext/Filter/Util/Call.xs                Filter::Util::Call extension external subroutines
+ext/Filter/Util/Makefile.PL    Filter::Util::Call extension makefile writer
 ext/GDBM_File/GDBM_File.pm     GDBM extension Perl module
 ext/GDBM_File/GDBM_File.xs     GDBM extension external subroutines
 ext/GDBM_File/Makefile.PL      GDBM extension makefile writer
@@ -680,6 +683,7 @@ lib/File/Temp.pm    create safe temporary files and file handles
 lib/File/stat.pm       By-name interface to Perl's builtin stat
 lib/FileCache.pm       Keep more files open than the system permits
 lib/FileHandle.pm      Backward-compatible front end to IO extension
+lib/Filter/Simple.pm   Simple frontend to Filter::Util::Call
 lib/FindBin.pm         Find name of currently executing program
 lib/Getopt/Long.pm     Fetch command options (GetOptions)
 lib/Getopt/Std.pm      Fetch command options (getopt, getopts)
@@ -1384,6 +1388,8 @@ t/lib/filefunc.t  See if File::Spec::Functions works
 t/lib/filehand.t       See if FileHandle works
 t/lib/filepath.t       See if File::Path works
 t/lib/filespec.t       See if File::Spec works
+t/lib/filt-util.t      See if Filter::Util::Call works
+t/lib/filt-util.pl     See if Filter::Util::Call works
 t/lib/findbin.t                See if FindBin works
 t/lib/ftmp-mktemp.t    See if File::Temp works
 t/lib/ftmp-posix.t     See if File::Temp works
diff --git a/ext/Filter/Util/Call.pm b/ext/Filter/Util/Call.pm
new file mode 100644 (file)
index 0000000..8d8d125
--- /dev/null
@@ -0,0 +1,470 @@
+package Filter::Util::Call ;
+
+require 5.002 ;
+require DynaLoader;
+require Exporter;
+use Carp ;
+use strict;
+use vars qw($VERSION @ISA @EXPORT) ;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ;
+$VERSION = "1.04" ;
+
+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 DESCRIPTION
+
+This module provides you with the framework to write I<Source Filters>
+in Perl.
+
+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 AUTHOR
+
+Paul Marquess 
+
+=head1 DATE
+
+26th January 1996
+
+=cut
+
diff --git a/ext/Filter/Util/Call.xs b/ext/Filter/Util/Call.xs
new file mode 100644 (file)
index 0000000..c8105d0
--- /dev/null
@@ -0,0 +1,252 @@
+/* 
+ * Filename : Call.xs
+ * 
+ * Author   : Paul Marquess 
+ * Date     : 26th March 2000
+ * Version  : 1.05
+ *
+ */
+
+#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(...)
+    PPCODE:
+    filter_del(filter_call);
+
+
+BOOT:
+    /* temporary hack to control debugging in toke.c */
+    if (fdebug)
+        filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");  
+
+
diff --git a/ext/Filter/Util/Makefile.PL b/ext/Filter/Util/Makefile.PL
new file mode 100644 (file)
index 0000000..01e1ca7
--- /dev/null
@@ -0,0 +1,6 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+       NAME            => 'Filter::Util::Call',
+       VERSION_FROM    => 'Call.pm',
+);
diff --git a/t/lib/filt-util.pl b/t/lib/filt-util.pl
new file mode 100644 (file)
index 0000000..1615873
--- /dev/null
@@ -0,0 +1,48 @@
+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;
diff --git a/t/lib/filt-util.t b/t/lib/filt-util.t
new file mode 100644 (file)
index 0000000..78f47b8
--- /dev/null
@@ -0,0 +1,791 @@
+BEGIN {
+    chdir('t') if -d 't';    
+    @INC = '.'; 
+    push @INC, '../lib';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ m{\bFilter/Util\b}) {
+        print "1..0 # Skip: Filter::Util was not built\n";
+        exit 0;
+    }
+    require 'lib/filt-util.pl';
+}
+
+print "1..28\n" ;
+
+$Perl = "$Perl -w" ;
+
+use Cwd ;
+$here = getcwd ;
+
+use vars qw($Inc $Perl);
+
+$filename = "call.tst" ;
+$filenamebin = "call.bin" ;
+$module   = "MyTest" ;
+$module2  = "MyTest2" ;
+$module3  = "MyTest3" ;
+$module4  = "MyTest4" ;
+$module5  = "MyTest5" ;
+$nested   = "nested" ;
+$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
+$a = `$Perl -I. $Inc -e "use ${module} ;"  2>&1` ;
+ok(1, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 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' && $? != 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
+
+$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) = 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 {
+    unlink $filename ;
+    unlink $filenamebin ;
+    unlink "${module}.pm" ;
+    unlink "${module2}.pm" ;
+    unlink "${module3}.pm" ;
+    unlink "${module4}.pm" ;
+    unlink "${module5}.pm" ;
+    unlink $nested ;
+    unlink "${block}.pm" ;
+}
+
+