dslinux/user/perl/ext/Filter/Util/Call Call.pm Call.xs Makefile.PL

cayenne dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:26:49 CET 2006

Update of /cvsroot/dslinux/dslinux/user/perl/ext/Filter/Util/Call
In directory antilope:/tmp/cvs-serv7729/ext/Filter/Util/Call

Added Files:
	Call.pm Call.xs Makefile.PL 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: Call.xs ---
 * Filename : Call.xs
 * Author   : Paul Marquess 
 * Date     : 11th November 2001
 * Version  : 1.06
 *    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.

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef _NOT_CORE
#  include "ppport.h"

/* Internal defines */
#define PERL_OBJECT(s)		IoTOP_GV(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)

/* Global Data */

#define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION
typedef struct {
    int x_fdebug ;
    int x_current_idx ;
} my_cxt_t;
#define fdebug          (MY_CXT.x_fdebug)
#define current_idx     (MY_CXT.x_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 ;
	    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 ;
	    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) ; */

	    /* 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

#define IDX		current_idx

	int	size 
	    SV * buffer = DEFSV ;

	    RETVAL = FILTER_READ(IDX + 1, buffer, size) ;

real_import(object, perlmodule, coderef)
    SV *	object
    char *	perlmodule 
    int		coderef
        SV * sv = newSV(1) ;

        (void)SvPOK_only(sv) ;
        filter_add(filter_call, sv) ;

	PERL_MODULE(sv) = savepv(perlmodule) ;
	PERL_OBJECT(sv) = (GV*) newSVsv(object) ;
        BUF_OFFSET(sv) = 0 ;
	CODE_REF(sv)   = coderef ;

        SvCUR_set(sv, 0) ;


	if (PL_rsfp_filters && IDX <= av_len(PL_rsfp_filters) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX)))

unimport(package="$Package", ...)
    char *package

    fdebug = 0;
    /* temporary hack to control debugging in toke.c */
    if (fdebug)
        filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");  

--- NEW FILE: Call.pm ---

# 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.0601" ;

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 ;


=head1 NAME

Filter::Util::Call - Perl Source Filter Utility Module


    use Filter::Util::Call ;


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) = @_ ;

                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

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>:


=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

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

    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>.


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

See the filters at the end of this documents for examples of using
context information using both I<method filters> and I<closure

=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

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

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.



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) ;

            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

    package Subst ;

    use Filter::Util::Call ;
    use Carp ;

    sub import
        croak("usage: use Subst qw(from to)")
            unless @_ == 3 ;
        my ($self, $from, $to) = @_ ;
                my ($status) ;
                    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" ;


    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:


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 ;

                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. Damian's 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


=head1 AUTHOR

Paul Marquess 

=head1 DATE

26th January 1996


--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;

	NAME      	=> 'Filter::Util::Call',
	VERSION_FROM   	=> 'Call.pm',
       MAN3PODS        => {},  # Pods will be built by installman.

More information about the dslinux-commit mailing list