Perl has a number of C functions that allow you to call Perl
subroutines. They are
- I32 call_sv(SV* sv, I32 flags) ;
- I32 call_pv(char *subname, I32 flags) ;
- I32 call_method(char *methname, I32 flags) ;
- I32 call_argv(char *subname, I32 flags, register char **argv) ;
+ I32 call_sv(SV* sv, I32 flags);
+ I32 call_pv(char *subname, I32 flags);
+ I32 call_method(char *methname, I32 flags);
+ I32 call_argv(char *subname, I32 flags, register char **argv);
The key function is I<call_sv>. All the other functions are
fairly simple wrappers which make it easier to call Perl subroutines in
sub joe
{ &fred }
- &joe(1,2,3) ;
+ &joe(1,2,3);
This will print
sub PrintUID
{
- print "UID is $<\n" ;
+ print "UID is $<\n";
}
and here is a C function to call it
static void
call_PrintUID()
{
- dSP ;
+ dSP;
- PUSHMARK(SP) ;
- call_pv("PrintUID", G_DISCARD|G_NOARGS) ;
+ PUSHMARK(SP);
+ call_pv("PrintUID", G_DISCARD|G_NOARGS);
}
Simple, eh.
sub LeftString
{
- my($s, $n) = @_ ;
- print substr($s, 0, $n), "\n" ;
+ my($s, $n) = @_;
+ print substr($s, 0, $n), "\n";
}
The C function required to call I<LeftString> would look like this.
static void
call_LeftString(a, b)
- char * a ;
- int b ;
+ char * a;
+ int b;
{
- dSP ;
+ dSP;
- ENTER ;
- SAVETMPS ;
+ ENTER;
+ SAVETMPS;
- PUSHMARK(SP) ;
+ PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(a, 0)));
XPUSHs(sv_2mortal(newSViv(b)));
- PUTBACK ;
+ PUTBACK;
call_pv("LeftString", G_DISCARD);
- FREETMPS ;
- LEAVE ;
+ FREETMPS;
+ LEAVE;
}
Here are a few notes on the C function I<call_LeftString>.
This is the purpose of
- ENTER ;
- SAVETMPS ;
+ ENTER;
+ SAVETMPS;
at the start of the function, and
- FREETMPS ;
- LEAVE ;
+ FREETMPS;
+ LEAVE;
at the end. The C<ENTER>/C<SAVETMPS> pair creates a boundary for any
temporaries we create. This means that the temporaries we get rid of
sub Adder
{
- my($a, $b) = @_ ;
- $a + $b ;
+ my($a, $b) = @_;
+ $a + $b;
}
Because we are now concerned with the return value from I<Adder>, the C
static void
call_Adder(a, b)
- int a ;
- int b ;
+ int a;
+ int b;
{
- dSP ;
- int count ;
+ dSP;
+ int count;
- ENTER ;
+ ENTER;
SAVETMPS;
- PUSHMARK(SP) ;
+ PUSHMARK(SP);
XPUSHs(sv_2mortal(newSViv(a)));
XPUSHs(sv_2mortal(newSViv(b)));
- PUTBACK ;
+ PUTBACK;
count = call_pv("Adder", G_SCALAR);
- SPAGAIN ;
+ SPAGAIN;
if (count != 1)
- croak("Big trouble\n") ;
+ croak("Big trouble\n");
- printf ("The sum of %d and %d is %d\n", a, b, POPi) ;
+ printf ("The sum of %d and %d is %d\n", a, b, POPi);
- PUTBACK ;
- FREETMPS ;
- LEAVE ;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
}
Points to note this time are
sub AddSubtract
{
- my($a, $b) = @_ ;
- ($a+$b, $a-$b) ;
+ my($a, $b) = @_;
+ ($a+$b, $a-$b);
}
and this is the C function
static void
call_AddSubtract(a, b)
- int a ;
- int b ;
+ int a;
+ int b;
{
- dSP ;
- int count ;
+ dSP;
+ int count;
- ENTER ;
+ ENTER;
SAVETMPS;
- PUSHMARK(SP) ;
+ PUSHMARK(SP);
XPUSHs(sv_2mortal(newSViv(a)));
XPUSHs(sv_2mortal(newSViv(b)));
- PUTBACK ;
+ PUTBACK;
count = call_pv("AddSubtract", G_ARRAY);
- SPAGAIN ;
+ SPAGAIN;
if (count != 2)
- croak("Big trouble\n") ;
+ croak("Big trouble\n");
- printf ("%d - %d = %d\n", a, b, POPi) ;
- printf ("%d + %d = %d\n", a, b, POPi) ;
+ printf ("%d - %d = %d\n", a, b, POPi);
+ printf ("%d + %d = %d\n", a, b, POPi);
- PUTBACK ;
- FREETMPS ;
- LEAVE ;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
}
If I<call_AddSubtract> is called like this
- call_AddSubtract(7, 4) ;
+ call_AddSubtract(7, 4);
then here is the output
static void
call_AddSubScalar(a, b)
- int a ;
- int b ;
+ int a;
+ int b;
{
- dSP ;
- int count ;
- int i ;
+ dSP;
+ int count;
+ int i;
- ENTER ;
+ ENTER;
SAVETMPS;
- PUSHMARK(SP) ;
+ PUSHMARK(SP);
XPUSHs(sv_2mortal(newSViv(a)));
XPUSHs(sv_2mortal(newSViv(b)));
- PUTBACK ;
+ PUTBACK;
count = call_pv("AddSubtract", G_SCALAR);
- SPAGAIN ;
+ SPAGAIN;
- printf ("Items Returned = %d\n", count) ;
+ printf ("Items Returned = %d\n", count);
- for (i = 1 ; i <= count ; ++i)
- printf ("Value %d = %d\n", i, POPi) ;
+ for (i = 1; i <= count; ++i)
+ printf ("Value %d = %d\n", i, POPi);
- PUTBACK ;
- FREETMPS ;
- LEAVE ;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
}
The other modification made is that I<call_AddSubScalar> will print the
simplicity it assumes that they are integer). So if
I<call_AddSubScalar> is called
- call_AddSubScalar(7, 4) ;
+ call_AddSubScalar(7, 4);
then the output will be
sub Inc
{
- ++ $_[0] ;
- ++ $_[1] ;
+ ++ $_[0];
+ ++ $_[1];
}
and here is a C function to call it.
static void
call_Inc(a, b)
- int a ;
- int b ;
+ int a;
+ int b;
{
- dSP ;
- int count ;
- SV * sva ;
- SV * svb ;
+ dSP;
+ int count;
+ SV * sva;
+ SV * svb;
- ENTER ;
+ ENTER;
SAVETMPS;
- sva = sv_2mortal(newSViv(a)) ;
- svb = sv_2mortal(newSViv(b)) ;
+ sva = sv_2mortal(newSViv(a));
+ svb = sv_2mortal(newSViv(b));
- PUSHMARK(SP) ;
+ PUSHMARK(SP);
XPUSHs(sva);
XPUSHs(svb);
- PUTBACK ;
+ PUTBACK;
count = call_pv("Inc", G_DISCARD);
if (count != 0)
croak ("call_Inc: expected 0 values from 'Inc', got %d\n",
- count) ;
+ count);
- printf ("%d + 1 = %d\n", a, SvIV(sva)) ;
- printf ("%d + 1 = %d\n", b, SvIV(svb)) ;
+ printf ("%d + 1 = %d\n", a, SvIV(sva));
+ printf ("%d + 1 = %d\n", b, SvIV(svb));
- FREETMPS ;
- LEAVE ;
+ FREETMPS;
+ LEAVE;
}
To be able to access the two parameters that were pushed onto the stack
sub Subtract
{
- my ($a, $b) = @_ ;
+ my ($a, $b) = @_;
- die "death can be fatal\n" if $a < $b ;
+ die "death can be fatal\n" if $a < $b;
- $a - $b ;
+ $a - $b;
}
and some C to call it
static void
call_Subtract(a, b)
- int a ;
- int b ;
+ int a;
+ int b;
{
- dSP ;
- int count ;
+ dSP;
+ int count;
- ENTER ;
+ ENTER;
SAVETMPS;
- PUSHMARK(SP) ;
+ PUSHMARK(SP);
XPUSHs(sv_2mortal(newSViv(a)));
XPUSHs(sv_2mortal(newSViv(b)));
- PUTBACK ;
+ PUTBACK;
count = call_pv("Subtract", G_EVAL|G_SCALAR);
- SPAGAIN ;
+ SPAGAIN;
/* Check the eval first */
if (SvTRUE(ERRSV))
{
STRLEN n_a;
- printf ("Uh oh - %s\n", SvPV(ERRSV, n_a)) ;
- POPs ;
+ printf ("Uh oh - %s\n", SvPV(ERRSV, n_a));
+ POPs;
}
else
{
if (count != 1)
croak("call_Subtract: wanted 1 value from 'Subtract', got %d\n",
- count) ;
+ count);
- printf ("%d - %d = %d\n", a, b, POPi) ;
+ printf ("%d - %d = %d\n", a, b, POPi);
}
- PUTBACK ;
- FREETMPS ;
- LEAVE ;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
}
If I<call_Subtract> is called thus
if (SvTRUE(ERRSV))
{
STRLEN n_a;
- printf ("Uh oh - %s\n", SvPV(ERRSV, n_a)) ;
- POPs ;
+ printf ("Uh oh - %s\n", SvPV(ERRSV, n_a));
+ POPs;
}
is the direct equivalent of this bit of Perl
- print "Uh oh - $@\n" if $@ ;
+ print "Uh oh - $@\n" if $@;
C<PL_errgv> is a perl global of type C<GV *> that points to the
symbol table entry containing the error. C<ERRSV> therefore
sub new { bless {}, $_[0] }
sub Subtract {
my($a,$b) = @_;
- die "death can be fatal" if $a < $b ;
+ die "death can be fatal" if $a < $b;
$a - $b;
}
sub DESTROY { call_Subtract(5, 4); }
sub fred
{
- print "Hello there\n" ;
+ print "Hello there\n";
}
- CallSubPV("fred") ;
+ CallSubPV("fred");
Here is a snippet of XSUB which defines I<CallSubPV>.
CallSubPV(name)
char * name
CODE:
- PUSHMARK(SP) ;
- call_pv(name, G_DISCARD|G_NOARGS) ;
+ PUSHMARK(SP);
+ call_pv(name, G_DISCARD|G_NOARGS);
That is fine as far as it goes. The thing is, the Perl subroutine
can be specified as only a string. For Perl 4 this was adequate,
CallSubSV(name)
SV * name
CODE:
- PUSHMARK(SP) ;
- call_sv(name, G_DISCARD|G_NOARGS) ;
+ PUSHMARK(SP);
+ call_sv(name, G_DISCARD|G_NOARGS);
Because we are using an SV to call I<fred> the following can all be used
- CallSubSV("fred") ;
- CallSubSV(\&fred) ;
- $ref = \&fred ;
- CallSubSV($ref) ;
- CallSubSV( sub { print "Hello there\n" } ) ;
+ CallSubSV("fred");
+ CallSubSV(\&fred);
+ $ref = \&fred;
+ CallSubSV($ref);
+ CallSubSV( sub { print "Hello there\n" } );
As you can see, I<call_sv> gives you much greater flexibility in
how you can specify the Perl subroutine.
be used later in the program, it not enough just to store a copy of the
pointer to the SV. Say the code above had been like this
- static SV * rememberSub ;
+ static SV * rememberSub;
void
SaveSub1(name)
SV * name
CODE:
- rememberSub = name ;
+ rememberSub = name;
void
CallSavedSub1()
CODE:
- PUSHMARK(SP) ;
- call_sv(rememberSub, G_DISCARD|G_NOARGS) ;
+ PUSHMARK(SP);
+ call_sv(rememberSub, G_DISCARD|G_NOARGS);
The reason this is wrong is that by the time you come to use the
pointer C<rememberSub> in C<CallSavedSub1>, it may or may not still refer
to the Perl subroutine that was recorded in C<SaveSub1>. This is
particularly true for these cases
- SaveSub1(\&fred) ;
- CallSavedSub1() ;
+ SaveSub1(\&fred);
+ CallSavedSub1();
- SaveSub1( sub { print "Hello there\n" } ) ;
- CallSavedSub1() ;
+ SaveSub1( sub { print "Hello there\n" } );
+ CallSavedSub1();
By the time each of the C<SaveSub1> statements above have been executed,
the SV*s which corresponded to the parameters will no longer exist.
Similarly, with this code
- $ref = \&fred ;
- SaveSub1($ref) ;
- $ref = 47 ;
- CallSavedSub1() ;
+ $ref = \&fred;
+ SaveSub1($ref);
+ $ref = 47;
+ CallSavedSub1();
you can expect one of these messages (which you actually get is dependent on
the version of Perl you are using)
A similar but more subtle problem is illustrated with this code
- $ref = \&fred ;
- SaveSub1($ref) ;
- $ref = \&joe ;
- CallSavedSub1() ;
+ $ref = \&fred;
+ SaveSub1($ref);
+ $ref = \&joe;
+ CallSavedSub1();
This time whenever C<CallSavedSub1> get called it will execute the Perl
subroutine C<joe> (assuming it exists) rather than C<fred> as was
To get around these problems it is necessary to take a full copy of the
SV. The code below shows C<SaveSub2> modified to do that
- static SV * keepSub = (SV*)NULL ;
+ static SV * keepSub = (SV*)NULL;
void
SaveSub2(name)
/* Take a copy of the callback */
if (keepSub == (SV*)NULL)
/* First time, so create a new SV */
- keepSub = newSVsv(name) ;
+ keepSub = newSVsv(name);
else
/* Been here before, so overwrite */
- SvSetSV(keepSub, name) ;
+ SvSetSV(keepSub, name);
void
CallSavedSub2()
CODE:
- PUSHMARK(SP) ;
- call_sv(keepSub, G_DISCARD|G_NOARGS) ;
+ PUSHMARK(SP);
+ call_sv(keepSub, G_DISCARD|G_NOARGS);
To avoid creating a new SV every time C<SaveSub2> is called,
the function first checks to see if it has been called before. If not,
sub PrintList
{
- my(@list) = @_ ;
+ my(@list) = @_;
foreach (@list) { print "$_\n" }
}
and here is an example of I<call_argv> which will call
I<PrintList>.
- static char * words[] = {"alpha", "beta", "gamma", "delta", NULL} ;
+ static char * words[] = {"alpha", "beta", "gamma", "delta", NULL};
static void
call_PrintList()
{
- dSP ;
+ dSP;
- call_argv("PrintList", G_DISCARD, words) ;
+ call_argv("PrintList", G_DISCARD, words);
}
Note that it is not necessary to call C<PUSHMARK> in this instance.
Consider the following Perl code
{
- package Mine ;
+ package Mine;
sub new
{
- my($type) = shift ;
+ my($type) = shift;
bless [@_]
}
sub Display
{
- my ($self, $index) = @_ ;
- print "$index: $$self[$index]\n" ;
+ my ($self, $index) = @_;
+ print "$index: $$self[$index]\n";
}
sub PrintID
{
- my($class) = @_ ;
- print "This is Class $class version 1.0\n" ;
+ my($class) = @_;
+ print "This is Class $class version 1.0\n";
}
}
name and a version number. The virtual method, C<Display>, prints out a
single element of the array. Here is an all Perl example of using it.
- $a = new Mine ('red', 'green', 'blue') ;
- $a->Display(1) ;
+ $a = new Mine ('red', 'green', 'blue');
+ $a->Display(1);
PrintID Mine;
will print
CODE:
PUSHMARK(SP);
XPUSHs(ref);
- XPUSHs(sv_2mortal(newSViv(index))) ;
+ XPUSHs(sv_2mortal(newSViv(index)));
PUTBACK;
- call_method(method, G_DISCARD) ;
+ call_method(method, G_DISCARD);
void
call_PrintID(class, method)
char * method
CODE:
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(class, 0))) ;
+ XPUSHs(sv_2mortal(newSVpv(class, 0)));
PUTBACK;
- call_method(method, G_DISCARD) ;
+ call_method(method, G_DISCARD);
So the methods C<PrintID> and C<Display> can be invoked like this
- $a = new Mine ('red', 'green', 'blue') ;
- call_Method($a, 'Display', 1) ;
- call_PrintID('Mine', 'PrintID') ;
+ $a = new Mine ('red', 'green', 'blue');
+ call_Method($a, 'Display', 1);
+ call_PrintID('Mine', 'PrintID');
The only thing to note is that in both the static and virtual methods,
the method name is not passed via the stack--it is used as the first
CODE:
I32 gimme = GIMME_V;
if (gimme == G_VOID)
- printf ("Context is Void\n") ;
+ printf ("Context is Void\n");
else if (gimme == G_SCALAR)
- printf ("Context is Scalar\n") ;
+ printf ("Context is Scalar\n");
else
- printf ("Context is Array\n") ;
+ printf ("Context is Array\n");
and here is some Perl to test it
- PrintContext ;
- $a = PrintContext ;
- @a = PrintContext ;
+ PrintContext;
+ $a = PrintContext;
+ @a = PrintContext;
The output from that will be
for you automatically whenever it regains control after the callback
has terminated. This is done by simply not using the
- ENTER ;
- SAVETMPS ;
+ ENTER;
+ SAVETMPS;
...
- FREETMPS ;
- LEAVE ;
+ FREETMPS;
+ LEAVE;
sequence in the callback (and not, of course, specifying the G_DISCARD
flag).
hypothetical function C<register_fatal> which registers the C function
to get called when a fatal error occurs.
- register_fatal(cb1) ;
+ register_fatal(cb1);
The single parameter C<cb1> is a pointer to a function, so you must
have defined C<cb1> in your code, say something like this
static void
cb1()
{
- printf ("Fatal Error\n") ;
- exit(1) ;
+ printf ("Fatal Error\n");
+ exit(1);
}
Now change that to call a Perl subroutine instead
static void
cb1()
{
- dSP ;
+ dSP;
- PUSHMARK(SP) ;
+ PUSHMARK(SP);
/* Call the Perl sub to process the callback */
- call_sv(callback, G_DISCARD) ;
+ call_sv(callback, G_DISCARD);
}
CODE:
/* Remember the Perl sub */
if (callback == (SV*)NULL)
- callback = newSVsv(fn) ;
+ callback = newSVsv(fn);
else
- SvSetSV(callback, fn) ;
+ SvSetSV(callback, fn);
/* register the callback with the external library */
- register_fatal(cb1) ;
+ register_fatal(cb1);
where the Perl equivalent of C<register_fatal> and the callback it
registers, C<pcb1>, might look like this
# Register the sub pcb1
- register_fatal(\&pcb1) ;
+ register_fatal(\&pcb1);
sub pcb1
{
- die "I'm dying...\n" ;
+ die "I'm dying...\n";
}
The mapping between the C callback and the Perl equivalent is stored in
void
ProcessRead(fh, buffer)
- int fh ;
- char * buffer ;
+ int fh;
+ char * buffer;
{
...
}
hash is a convenient mechanism for storing this mapping. The code
below shows a possible implementation
- static HV * Mapping = (HV*)NULL ;
+ static HV * Mapping = (HV*)NULL;
void
asynch_read(fh, callback)
CODE:
/* If the hash doesn't already exist, create it */
if (Mapping == (HV*)NULL)
- Mapping = newHV() ;
+ Mapping = newHV();
/* Save the fh -> callback mapping */
- hv_store(Mapping, (char*)&fh, sizeof(fh), newSVsv(callback), 0) ;
+ hv_store(Mapping, (char*)&fh, sizeof(fh), newSVsv(callback), 0);
/* Register with the C Library */
- asynch_read(fh, asynch_read_if) ;
+ asynch_read(fh, asynch_read_if);
and C<asynch_read_if> could look like this
static void
asynch_read_if(fh, buffer)
- int fh ;
- char * buffer ;
+ int fh;
+ char * buffer;
{
- dSP ;
- SV ** sv ;
+ dSP;
+ SV ** sv;
/* Get the callback associated with fh */
- sv = hv_fetch(Mapping, (char*)&fh , sizeof(fh), FALSE) ;
+ sv = hv_fetch(Mapping, (char*)&fh , sizeof(fh), FALSE);
if (sv == (SV**)NULL)
- croak("Internal error...\n") ;
+ croak("Internal error...\n");
- PUSHMARK(SP) ;
- XPUSHs(sv_2mortal(newSViv(fh))) ;
- XPUSHs(sv_2mortal(newSVpv(buffer, 0))) ;
- PUTBACK ;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSViv(fh)));
+ XPUSHs(sv_2mortal(newSVpv(buffer, 0)));
+ PUTBACK;
/* Call the Perl sub */
- call_sv(*sv, G_DISCARD) ;
+ call_sv(*sv, G_DISCARD);
}
For completeness, here is C<asynch_close>. This shows how to remove
int fh
CODE:
/* Remove the entry from the hash */
- (void) hv_delete(Mapping, (char*)&fh, sizeof(fh), G_DISCARD) ;
+ (void) hv_delete(Mapping, (char*)&fh, sizeof(fh), G_DISCARD);
/* Now call the real asynch_close */
- asynch_close(fh) ;
+ asynch_close(fh);
So the Perl interface would look like this
sub callback1
{
- my($handle, $buffer) = @_ ;
+ my($handle, $buffer) = @_;
}
# Register the Perl callback
- asynch_read($fh, \&callback1) ;
+ asynch_read($fh, \&callback1);
- asynch_close($fh) ;
+ asynch_close($fh);
The mapping between the C callback and Perl is stored in the global
hash C<Mapping> this time. Using a hash has the distinct advantage that
void
ProcessRead(buffer)
- char * buffer ;
+ char * buffer;
{
...
}
#define MAX_CB 3
#define NULL_HANDLE -1
- typedef void (*FnMap)() ;
+ typedef void (*FnMap)();
struct MapStruct {
- FnMap Function ;
- SV * PerlSub ;
- int Handle ;
- } ;
+ FnMap Function;
+ SV * PerlSub;
+ int Handle;
+ };
- static void fn1() ;
- static void fn2() ;
- static void fn3() ;
+ static void fn1();
+ static void fn2();
+ static void fn3();
static struct MapStruct Map [MAX_CB] =
{
{ fn1, NULL, NULL_HANDLE },
{ fn2, NULL, NULL_HANDLE },
{ fn3, NULL, NULL_HANDLE }
- } ;
+ };
static void
Pcb(index, buffer)
- int index ;
- char * buffer ;
+ int index;
+ char * buffer;
{
- dSP ;
+ dSP;
- PUSHMARK(SP) ;
- XPUSHs(sv_2mortal(newSVpv(buffer, 0))) ;
- PUTBACK ;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv(buffer, 0)));
+ PUTBACK;
/* Call the Perl sub */
- call_sv(Map[index].PerlSub, G_DISCARD) ;
+ call_sv(Map[index].PerlSub, G_DISCARD);
}
static void
fn1(buffer)
- char * buffer ;
+ char * buffer;
{
- Pcb(0, buffer) ;
+ Pcb(0, buffer);
}
static void
fn2(buffer)
- char * buffer ;
+ char * buffer;
{
- Pcb(1, buffer) ;
+ Pcb(1, buffer);
}
static void
fn3(buffer)
- char * buffer ;
+ char * buffer;
{
- Pcb(2, buffer) ;
+ Pcb(2, buffer);
}
void
int fh
SV * callback
CODE:
- int index ;
- int null_index = MAX_CB ;
+ int index;
+ int null_index = MAX_CB;
/* Find the same handle or an empty entry */
- for (index = 0 ; index < MAX_CB ; ++index)
+ for (index = 0; index < MAX_CB; ++index)
{
if (Map[index].Handle == fh)
- break ;
+ break;
if (Map[index].Handle == NULL_HANDLE)
- null_index = index ;
+ null_index = index;
}
if (index == MAX_CB && null_index == MAX_CB)
- croak ("Too many callback functions registered\n") ;
+ croak ("Too many callback functions registered\n");
if (index == MAX_CB)
- index = null_index ;
+ index = null_index;
/* Save the file handle */
- Map[index].Handle = fh ;
+ Map[index].Handle = fh;
/* Remember the Perl sub */
if (Map[index].PerlSub == (SV*)NULL)
- Map[index].PerlSub = newSVsv(callback) ;
+ Map[index].PerlSub = newSVsv(callback);
else
- SvSetSV(Map[index].PerlSub, callback) ;
+ SvSetSV(Map[index].PerlSub, callback);
- asynch_read(fh, Map[index].Function) ;
+ asynch_read(fh, Map[index].Function);
void
array_asynch_close(fh)
int fh
CODE:
- int index ;
+ int index;
/* Find the file handle */
- for (index = 0; index < MAX_CB ; ++ index)
+ for (index = 0; index < MAX_CB; ++ index)
if (Map[index].Handle == fh)
- break ;
+ break;
if (index == MAX_CB)
- croak ("could not close fh %d\n", fh) ;
+ croak ("could not close fh %d\n", fh);
- Map[index].Handle = NULL_HANDLE ;
- SvREFCNT_dec(Map[index].PerlSub) ;
- Map[index].PerlSub = (SV*)NULL ;
+ Map[index].Handle = NULL_HANDLE;
+ SvREFCNT_dec(Map[index].PerlSub);
+ Map[index].PerlSub = (SV*)NULL;
- asynch_close(fh) ;
+ asynch_close(fh);
In this case the functions C<fn1>, C<fn2>, and C<fn3> are used to
remember the Perl subroutine to be called. Each of the functions holds
static void
call_AddSubtract2(a, b)
- int a ;
- int b ;
+ int a;
+ int b;
{
- dSP ;
- I32 ax ;
- int count ;
+ dSP;
+ I32 ax;
+ int count;
- ENTER ;
+ ENTER;
SAVETMPS;
- PUSHMARK(SP) ;
+ PUSHMARK(SP);
XPUSHs(sv_2mortal(newSViv(a)));
XPUSHs(sv_2mortal(newSViv(b)));
- PUTBACK ;
+ PUTBACK;
count = call_pv("AddSubtract", G_ARRAY);
- SPAGAIN ;
- SP -= count ;
- ax = (SP - PL_stack_base) + 1 ;
+ SPAGAIN;
+ SP -= count;
+ ax = (SP - PL_stack_base) + 1;
if (count != 2)
- croak("Big trouble\n") ;
+ croak("Big trouble\n");
- printf ("%d + %d = %d\n", a, b, SvIV(ST(0))) ;
- printf ("%d - %d = %d\n", a, b, SvIV(ST(1))) ;
+ printf ("%d + %d = %d\n", a, b, SvIV(ST(0)));
+ printf ("%d - %d = %d\n", a, b, SvIV(ST(1)));
- PUTBACK ;
- FREETMPS ;
- LEAVE ;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
}
Notes
The code
- SPAGAIN ;
- SP -= count ;
- ax = (SP - PL_stack_base) + 1 ;
+ SPAGAIN;
+ SP -= count;
+ ax = (SP - PL_stack_base) + 1;
sets the stack up so that we can use the C<ST> macro.
Line numbers have been added to allow specific lines to be referenced
easily.
- 1: use Filter::cpp ;
+ 1: use Filter::cpp;
2: #define TRUE 1
- 3: $a = TRUE ;
- 4: print "a = $a\n" ;
+ 3: $a = TRUE;
+ 4: print "a = $a\n";
When you execute this script, Perl creates a source stream for the
file. Before the parser processes any of the lines from the file, the
The parser then sees the following code:
- use Filter::cpp ;
- $a = 1 ;
- print "a = $a\n" ;
+ use Filter::cpp;
+ $a = 1;
+ print "a = $a\n";
Let's consider what happens when the filtered code includes another
module with use:
- 1: use Filter::cpp ;
+ 1: use Filter::cpp;
2: #define TRUE 1
- 3: use Fred ;
- 4: $a = TRUE ;
- 5: print "a = $a\n" ;
+ 3: use Fred;
+ 4: $a = TRUE;
+ 5: print "a = $a\n";
The C<cpp> filter does not apply to the text of the Fred module, only
to the text of the file that used it (C<cpp_test>). Although the use
possible to stack a uudecode filter and an uncompression filter like
this:
- use Filter::uudecode ; use Filter::uncompress ;
+ use Filter::uudecode; use Filter::uncompress;
M'XL(".H<US4''V9I;F%L')Q;>7/;1I;_>_I3=&E=%:F*I"T?22Q/
M6]9*<IQCO*XFT"0[PL%%'Y+IG?WN^ZYN-$'J.[.JE$,20/?K=_[>
...
Here is an example script that uses C<Filter::sh>:
- use Filter::sh 'tr XYZ PQR' ;
- $a = 1 ;
- print "XYZ a = $a\n" ;
+ use Filter::sh 'tr XYZ PQR';
+ $a = 1;
+ print "XYZ a = $a\n";
The output you'll get when the script is executed:
becomes M.)
- package Rot13 ;
+ package Rot13;
- use Filter::Util::Call ;
+ use Filter::Util::Call;
sub import {
- my ($type) = @_ ;
- my ($ref) = [] ;
- filter_add(bless $ref) ;
+ my ($type) = @_;
+ my ($ref) = [];
+ filter_add(bless $ref);
}
sub filter {
- my ($self) = @_ ;
- my ($status) ;
+ my ($self) = @_;
+ my ($status);
tr/n-za-mN-ZA-M/a-zA-Z/
- if ($status = filter_read()) > 0 ;
- $status ;
+ if ($status = filter_read()) > 0;
+ $status;
}
1;
the source file in rot13 format. The script below, C<mkrot13>, does
just that.
- die "usage mkrot13 filename\n" unless @ARGV ;
- my $in = $ARGV[0] ;
- my $out = "$in.tmp" ;
+ die "usage mkrot13 filename\n" unless @ARGV;
+ my $in = $ARGV[0];
+ my $out = "$in.tmp";
open(IN, "<$in") or die "Cannot open file $in: $!\n";
open(OUT, ">$out") or die "Cannot open file $out: $!\n";
- print OUT "use Rot13;\n" ;
+ print OUT "use Rot13;\n";
while (<IN>) {
- tr/a-zA-Z/n-za-mN-ZA-M/ ;
- print OUT ;
+ tr/a-zA-Z/n-za-mN-ZA-M/;
+ print OUT;
}
close IN;
If we encrypt this with C<mkrot13>:
- print " hello fred \n" ;
+ print " hello fred \n";
the result will be this:
use Rot13;
- cevag "uryyb serq\a" ;
+ cevag "uryyb serq\a";
Running it produces this output:
## DEBUG_BEGIN
if ($year > 1999) {
- warn "Debug: millennium bug in year $year\n" ;
+ warn "Debug: millennium bug in year $year\n";
}
## DEBUG_END
## DEBUG_BEGIN
#if ($year > 1999) {
- # warn "Debug: millennium bug in year $year\n" ;
+ # warn "Debug: millennium bug in year $year\n";
#}
## DEBUG_END
use strict;
use warnings;
- use Filter::Util::Call ;
+ use Filter::Util::Call;
- use constant TRUE => 1 ;
- use constant FALSE => 0 ;
+ use constant TRUE => 1;
+ use constant FALSE => 0;
sub import {
- my ($type) = @_ ;
+ my ($type) = @_;
my (%context) = (
Enabled => defined $ENV{DEBUG},
InTraceBlock => FALSE,
Filename => (caller)[1],
LineNo => 0,
LastBegin => 0,
- ) ;
- filter_add(bless \%context) ;
+ );
+ filter_add(bless \%context);
}
sub Die {
- my ($self) = shift ;
- my ($message) = shift ;
- my ($line_no) = shift || $self->{LastBegin} ;
+ my ($self) = shift;
+ my ($message) = shift;
+ my ($line_no) = shift || $self->{LastBegin};
die "$message at $self->{Filename} line $line_no.\n"
}
sub filter {
- my ($self) = @_ ;
- my ($status) ;
- $status = filter_read() ;
- ++ $self->{LineNo} ;
+ my ($self) = @_;
+ my ($status);
+ $status = filter_read();
+ ++ $self->{LineNo};
# deal with EOF/error first
if ($status <= 0) {
$self->Die("DEBUG_BEGIN has no DEBUG_END")
- if $self->{InTraceBlock} ;
- return $status ;
+ if $self->{InTraceBlock};
+ return $status;
}
if ($self->{InTraceBlock}) {
if (/^\s*##\s*DEBUG_BEGIN/ ) {
$self->Die("Nested DEBUG_BEGIN", $self->{LineNo})
} elsif (/^\s*##\s*DEBUG_END/) {
- $self->{InTraceBlock} = FALSE ;
+ $self->{InTraceBlock} = FALSE;
}
# comment out the debug lines when the filter is disabled
- s/^/#/ if ! $self->{Enabled} ;
+ s/^/#/ if ! $self->{Enabled};
} elsif ( /^\s*##\s*DEBUG_BEGIN/ ) {
- $self->{InTraceBlock} = TRUE ;
- $self->{LastBegin} = $self->{LineNo} ;
+ $self->{InTraceBlock} = TRUE;
+ $self->{LastBegin} = $self->{LineNo};
} elsif ( /^\s*##\s*DEBUG_END/ ) {
$self->Die("DEBUG_END has no DEBUG_BEGIN", $self->{LineNo});
}
- return $status ;
+ return $status;
}
- 1 ;
+ 1;
The big difference between this filter and the previous example is the
use of context data in the filter object. The filter object is based on
essence of the filter is as follows:
sub filter {
- my ($self) = @_ ;
- my ($status) ;
- $status = filter_read() ;
+ my ($self) = @_;
+ my ($status);
+ $status = filter_read();
# deal with EOF/error first
- return $status if $status <= 0 ;
+ return $status if $status <= 0;
if ($self->{InTraceBlock}) {
if (/^\s*##\s*DEBUG_END/) {
$self->{InTraceBlock} = FALSE
}
# comment out debug lines when the filter is disabled
- s/^/#/ if ! $self->{Enabled} ;
+ s/^/#/ if ! $self->{Enabled};
} elsif ( /^\s*##\s*DEBUG_BEGIN/ ) {
- $self->{InTraceBlock} = TRUE ;
+ $self->{InTraceBlock} = TRUE;
}
- return $status ;
+ return $status;
}
Be warned: just as the C-preprocessor doesn't know C, the Debug filter
into this:
sub MySub($$@) {
- my ($first) = shift ;
- my ($second) = shift ;
- my (@rest) = @_ ;
+ my ($first) = shift;
+ my ($second) = shift;
+ my (@rest) = @_;
...
}
projects / p5sagit/p5-mst-13.2.git / commitdiff