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.
*
*/
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef _NOT_CORE
# include "ppport.h"
#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)
/* Global Data */
#define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION
typedef struct {
int x_fdebug ;
int x_current_idx ;
} my_cxt_t;
START_MY_CXT
#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)
{
dMY_CXT;
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:
{
dMY_CXT;
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:
dMY_CXT;
if (PL_rsfp_filters && IDX <= av_len(PL_rsfp_filters) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX)))
FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
void
unimport(package="$Package", ...)
char *package
PPCODE:
filter_del(filter_call);
BOOT:
{
MY_CXT_INIT;
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 ;
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. 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
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
--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Filter::Util::Call',
VERSION_FROM => 'Call.pm',
MAN3PODS => {}, # Pods will be built by installman.
);
More information about the dslinux-commit
mailing list