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
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)
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
--- /dev/null
+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
+
--- /dev/null
+/*
+ * 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");
+
+
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Filter::Util::Call',
+ VERSION_FROM => 'Call.pm',
+);
--- /dev/null
+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;
--- /dev/null
+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" ;
+}
+
+
projects / p5sagit/p5-mst-13.2.git / commitdiff