NetNews Usenet Archive 1992 #19/NN_1992_19.iso/spool/comp/lang/perl/5603

Text File | 1992-08-30 | 20.1 KB | 738 lines

Newsgroups: comp.lang.perl
Path: sparky!uunet!s5!is1.is.morgan.com!is0.is.morgan.com!robt
From: [e-mail] (Rob Torop)
Subject: usersub: HOW TO
Message-ID: <[e-mail]>
Sender: [e-mail]
Nntp-Posting-Host: idt101
Organization: Morgan Stanley & Company
Distribution: comp.lang.perl
Date: Sun, 30 Aug 1992 04:27:37 GMT
Lines: 725

#--------------------------------CUT HERE-------------------------------------
#! /bin/sh
#
# This is a shell archive.  Save this into a file, edit it
# and delete all lines above this comment.  Then give this
# file to sh by executing the command "sh file".  The files
# will be extracted into the current directory owned by
# you with default permissions.
#
# The files contained herein are:
#
# -r--r--r--  1 robt         7077 Aug 29 15:58 usub.doc
# -r--r--r--  1 robt         1686 Aug 29 15:49 ex1.mus
# -r--r--r--  1 robt         1714 Aug 29 15:49 ex2.mus
# -r--r--r--  1 robt         2287 Aug 29 15:49 ex3.mus
# -r--r--r--  1 robt          480 Aug 29 15:56 exfns.c
# -r--r--r--  1 robt          266 Aug 29 15:36 exfns.h
# -r--r--r--  1 robt          892 Aug 29 23:20 makefile
# -r--r--r--  1 robt         1370 Aug 29 16:09 extest.pl
#
echo 'x - usub.doc'
if test -f usub.doc; then echo 'shar: not overwriting usub.doc'; else
sed 's/^X//' << '________This_Is_The_END________' > usub.doc
X/*
X *   Last edited by:  $Author: robt $
X *               on:  $Date: 1992/08/29 19:58:19 $
X *         Filename:  $RCSfile: usub.doc,v $
X *         Revision:  $Revision: 1.3 $
X */
X
X                 usub: Hooking C functions in to perl
X                 ------------------------------------
X
XRobert Torop ([e-mail])
X
XThese notes do not represent the views of Morgan Stanley & Co. in any
Xway.  I am solely responsible for the contents.
X
XThese notes describe in detail how to hook functions into perl using
Xthe "usersub" mechanism.  Assuming people are interested, I will post
Xnew versions when (and if!) I figure out more, particularly about
Xassociative arrays.  You might want to skip reading this all together
Xand just look at the sample programs (see the makefile).
X
XIntroduction
X------------
X
XYou should have the following files:
X
X    makefile            Makes the examples
X    usub.doc            These notes
X    ex1.mus             Glue to hook "opie" from exfns.c into perl
X    ex2.mus             Glue to hook more of exfns.c into perl
X    ex3.mus             Same as ex3.mus, with an example of
X                        returning an array.
X    exfns.c             Functions to be hooked in to perl in examples
X    exfns.h             Header file for exfns.c
X    extest.pl           Small program to test that the new functions
X                        are there.
X
XYou will also need uperl.o (should have been created when perl was
Xbuilt), the .h files from perl, and the program mus, all of which
Xshould be in your perl source directory.  You should also take a look
Xat README in the usub directory under the perl source.
X
XDANGER WILL ROBINSON!
X---------------------
X
XIf you are using perl with patchlevel < 20, you may have memory
Xleakage problems.  I did, with functions that return arrays.  This is
Xapparently due to a problem which has been fixed.  When I compile
Xusing patchlevel 35, I have no such problems.  This may not be a big
Xdeal - I had to run around 100K calls before perl barfed.
X
XBasic Structure
X---------------
X
Xperl hooks in functions and variables using two enumerated variables,
Xand four functions.
X
X    1) An enum variable called usersubs, the elements of which look like
X       US_functionName.  For example:
X
X            static enum usersubs { US_aGreatFunction };
X
X       These values will be passed to usersub (see below) so it can
X       tell what function has been called.
X
X    2) An enum variable called uservars, the elements of which look like
X       UV_variableName.  For example:
X
X            static enum uservars { UV_anImportantVariable };
X
X       These values will be passed to userset and userval (see below) so
X       tell what variable is being set/retrieved.
X
X    3) Four functions, userinit, usersub, userset, and userval, the
X       latter two two of which are required only if one is using uservars.
X
Xuserinit performs any initializations needed.  This can be
X
X    1) Any initialization needed by the code you're hooking in.
X    2) Registering the functions enumerated in usersubs using make_usub.
X    3) Setting the uf_set and uf_get fields of a global struct ufuncs
X       for use by MAGICVAR.
X    4) Registering the variables enumerated in uservals using the
X       MAGICVAR macro.
X
Xusersub gets passed the enumerated value of the function being called
X(eg US_myFunction), the number of parameters, and a pointer to the perl
Xstack.  It is just a switch on the US_ value, each case of which must
Xpull parameters off the stack and put them back on appropriately.  The
Xmus program helps in this - if a function is simple enough, it will fill
Xin the code for you.  Our examples use mus to do this.
X
Xuserval is called when the perl program tries to get the value of a
Xvariable defined in your struct uservals.  It gets passed a (STR *)
Xwhich it must fill in, usually using the functions str_numset or
Xstr_set.
X
Xuserset is called when the perl program tries to set the value of a
Xvariable defined in your struct uservals.  It gets passed a (STR *)
Xfrom which it must extract and set the variable, usually using
Xstr_gnum or str_get.  (These could be either functions or macros,
Xdepending on the value of the symbol CRIPPLED_CC - don't worry about
Xit.).
X
Xmus
X---
X
Xmus is a program which makes using usub easier.  The input to mus is
Xan "extended" C source.  The output of mus is a C program which
Xcontains code to check the number of arguments, extract the arguments
Xfrom the perl stack, calls your function and then puts the result back
Xon the stack.  It only handles scalar values, but see example 3 for
Xthe way to return an array.  You should run mus on the examples and
Xlook at the resulting C programs.  In particular, doing this will show
Xyou how to use str_set, str_setnum, str_get, and str_gnum.
X
XA Handy Hint
X------------
X
XIf you compile with debugging on, you can dbx (or whatever) your copy
Xof perl and stop in usersub to see what's going on like this:
X
X       $ dbx myperl
X       (dbx) stop in usersub
X       (dbx) run -de 0
X       <DB>1 $x = &myFunction('hello');  # now you're in the perl debugger
X       stopped at usersub at line ....   # now you're in dbx
X       (dbx)
X
X
XIf you trace in far enough, st[1] will be the first argument you passed
Xto the function.  Have fun...
X
XExample 1
X---------
X
XIn this example, we have a function already written, with prototype
X
X    double opie(double);
X
Xin the file exfns.c, and we want to call it from perl like this
X
X    $x = 12.3;
X    print &opie($x), "\n";
X
XThe file ex1.mus contains all that is needed.  In this simple
Xcase, that's not much.  The makefile runs ex1.mus through the mus
Xpreprocessor, creating ex1.c.  Since all we want opie to do is
Xreturn a scalar, we don't have to worry about the perl stack and the
XCASE/END construction does the trick.
X
XExample 2
X---------
X
XIn this example, we add two functions from exfns.c
X
X    int    andy(int);
X    char * helen(int, char *);
X
Xand our own "magic" variable
X
X    int Mayberry;
X
XThey will be used in perl like this
X
X    $n = &andy(0);
X    $x = &helen($n, "crump"); # This could change the value of $Mayberry
X    print $Mayberry, "\n";
X    $Mayberry = 12;
X
XAgain, we can use mus directly for this, and the code is in
Xex2.mus.  The main difference, other than using different function
Xtypes is that we have two additional functions, userset and userval,
Xwhich are used when we set or retrieve the value of a user variable,
Xin this case $Mayberry.  Note the way in which these functions are
Xregistered in userinit.
X
XExample 3 (Harder Stuff - returning arrays)
X-------------------------------------------
X
Xex3.mus is the same as ex2.mus, except that a new function,
Xcalled otis has been added.  &otis($n) returns an array of the squares
Xof the integers between 1 and $n.  This involves some messing around
Xwith the perl stack, and using the function astore to enlarge the
Xstack, the function str_nmake to create new numeric elements, and the
Xfunction str_2mortal to let perl know that it can reclaim the memory
Xused for the return value.
X
X
X
X
________This_Is_The_END________
if test `wc -c < usub.doc` -ne     7077; then
    echo 'shar: usub.doc was damaged during transit (should have been     7077 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - ex1.mus'
if test -f ex1.mus; then echo 'shar: not overwriting ex1.mus'; else
sed 's/^X//' << '________This_Is_The_END________' > ex1.mus
X/*
X *   Last edited by:  $Author: robt $
X *               on:  $Date: 1992/08/29 19:49:20 $
X *         Filename:  $RCSfile: ex1.mus,v $
X *         Revision:  $Revision: 1.2 $
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X#include "exfns.h"
X
X/*
X * Try dbxing your customized perl and stop in usersub to
X * see what's going on. Do this:
X *
X *          dbx myperl
X *          (dbx) stop in usersub
X *          (dbx) run -de 0
X *
X *          <DB>1 $x = &myFunction('hello');  # now you're in perl
X *
X * and you'll find yourself in usersub.
X */
X
X
X/*
X * We'll be hooking in only one function, opie from exfns.c,
X * and no variables.
X */
X
Xstatic enum usersubs {
X    US_opie
X};
X
Xstatic int usersub();
Xint userinit();
X
Xint
Xuserinit()
X{
X    char * filename = "ex1.mus";
X
X    /* Register opie with perl */
X    make_usub("opie", US_opie,    usersub, filename);
X}
X
X
X
Xstatic int
Xusersub(ix, sp, items)
X    int ix;               /* the US_ value of the function being called */
X    register int sp;      /* perl stack pointer                         */
X    register int items;   /* # of args passed                           */
X{
X    STR **st = stack->ary_array + sp; /* used in code generated by mus */
X    register STR *Str;        /* used in str_get and str_gnum macros */
X
X    switch (ix) {
X
X/*
X * Running mus ex1.mus > ex1.c will cause this to be expanded
X * into code that will 1) check that exactly one item has been passed
X * in, 2) extract the argument x from the stack, 3) call opie, and
X * 4) return the value to perl.  Take a look at the output of mus.
X */
XCASE double opie
XI   double x
XEND
X
X    default:
X    fatal("Unimplemented user-defined subroutine");
X    }
X
X    return sp;
X}
X
X
X
________This_Is_The_END________
if test `wc -c < ex1.mus` -ne     1686; then
    echo 'shar: ex1.mus was damaged during transit (should have been     1686 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - ex2.mus'
if test -f ex2.mus; then echo 'shar: not overwriting ex2.mus'; else
sed 's/^X//' << '________This_Is_The_END________' > ex2.mus
X/*
X *   Last edited by:  $Author: robt $
X *               on:  $Date: 1992/08/29 19:49:20 $
X *         Filename:  $RCSfile: ex2.mus,v $
X *         Revision:  $Revision: 1.2 $
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X#include "exfns.h"
X
X/*
X *  We'll hook in three functions: opie, andy, and helen.
X */
Xstatic enum usersubs {
X    US_opie,
X    US_andy,
X    US_helen
X};
X
X/*
X * We'll hook on one variable, Mayberry
X */
Xstatic enum uservars {
X    UV_Mayberry
X};
X
Xstatic int usersub();
Xint userinit();
Xstatic int userset();
Xstatic int userval();
X
Xint
Xuserinit()
X{
X#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
X    char * filename = "ex2.mus";
X    static struct ufuncs uf;
X
X    uf.uf_set = userset;
X    uf.uf_val = userval;
X
X    make_usub("opie",  US_opie,  usersub, filename);
X    make_usub("andy",  US_andy,     usersub, filename);
X    make_usub("helen", US_helen, usersub, filename);
X    MAGICVAR("Mayberry", UV_Mayberry);
X}
X
X
Xstatic int
Xusersub(ix, sp, items)
X    int ix;
X    register int sp;
X    register int items;
X{
X    STR **st = stack->ary_array + sp;
X    register STR *Str;        /* used in str_get and str_gnum macros */
X
X    switch (ix) {
X
XCASE double opie
XI   double x
XEND
X
XCASE int andy
XI   int x
XEND
X
XCASE char * helen
XI   int x
XI   char * y
XEND
X
X    default:
X    fatal("Unimplemented user-defined subroutine");
X    }
X
X    return sp;
X}
X
X
Xstatic int
Xuserval(ix, str)
X    int ix;
X    STR *str;
X{
X    switch (ix) {
X    case UV_Mayberry:
X    str_numset(str, (double)Mayberry);
X    break;
X    }
X    return 0;
X}
X
X
Xstatic int
Xuserset(ix, str)
X    int ix;
X    STR *str;
X{
X    switch (ix) {
X    case UV_Mayberry:
X        Mayberry = (double)str_gnum(str);
X    break;
X    }
X    return 0;
X}
X
________This_Is_The_END________
if test `wc -c < ex2.mus` -ne     1714; then
    echo 'shar: ex2.mus was damaged during transit (should have been     1714 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - ex3.mus'
if test -f ex3.mus; then echo 'shar: not overwriting ex3.mus'; else
sed 's/^X//' << '________This_Is_The_END________' > ex3.mus
X/*
X *   Last edited by:  $Author: robt $
X *               on:  $Date: 1992/08/29 19:49:20 $
X *         Filename:  $RCSfile: ex3.mus,v $
X *         Revision:  $Revision: 1.2 $
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X#include "exfns.h"
X
Xstatic enum usersubs {
X    US_opie,
X    US_andy,
X    US_helen,
X    US_otis
X};
X
Xstatic enum uservars {
X    UV_Mayberry
X};
X
Xint userinit();
Xstatic int usersub();
Xstatic int userset();
Xstatic int userval();
X
Xint
Xuserinit()
X{
X#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
X    char * filename = "ex2.mus";
X    static struct ufuncs uf;
X
X    uf.uf_set = userset;
X    uf.uf_val = userval;
X
X    make_usub("opie",  US_opie,  usersub, filename);
X    make_usub("andy",  US_andy,     usersub, filename);
X    make_usub("helen", US_helen, usersub, filename);
X    make_usub("otis",   US_otis, usersub, filename);
X    MAGICVAR("Mayberry", UV_Mayberry);
X}
X
X
Xstatic int
Xusersub(ix, sp, items)
X    int ix;
X    register int sp;
X    register int items;
X{
X    STR **st = stack->ary_array + sp; /* for stack access */
X    register STR *Str;        /* used in str_get and str_gnum macros */
X
X    switch (ix) {
X
XCASE double opie
XI   double x
XEND
X
XCASE int andy
XI   int x
XEND
X
XCASE char * helen
XI   int x
XI   char * y
XEND
X
X      case US_otis:
X      if (items != 1)
X        fatal("Usage: &otis($x)");
X      else {
X        int n = (int) str_gnum(st[1]); /* argument passed from perl */
X        int i;
X
X        if (n <= 0)
X            fatal("Argument to &otis must be positive!");
X
X        astore(stack, sp + n, NULL); /* force stack to grow */
X        st = stack->ary_array + sp;  /* stack may have changed */
X        for (i = 1; i <= n; i++) {
X            /* important: pass a double to str_nmake, not an int! */
X            st[i-1] = str_2mortal(str_nmake( (double)(i*i) ));
X        }
X        return sp + n - 1;
X    }
X
X
X    default:
X    fatal("Unimplemented user-defined subroutine");
X    }
X
X    return sp;
X}
X
X
Xstatic int
Xuserval(ix, str)
X    int ix;
X    STR *str;
X{
X    switch (ix) {
X    case UV_Mayberry:
X    str_numset(str, (double)Mayberry);
X    break;
X    }
X    return 0;
X}
X
X
Xstatic int
Xuserset(ix, str)
X    int ix;
X    STR *str;
X{
X    switch (ix) {
X    case UV_Mayberry:
X        Mayberry = (int)str_gnum(str);
X    break;
X    }
X    return 0;
X}
X
X
X
________This_Is_The_END________
if test `wc -c < ex3.mus` -ne     2287; then
    echo 'shar: ex3.mus was damaged during transit (should have been     2287 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - exfns.c'
if test -f exfns.c; then echo 'shar: not overwriting exfns.c'; else
sed 's/^X//' << '________This_Is_The_END________' > exfns.c
X/*
X *   Last edited by:  $Author: robt $
X *               on:  $Date: 1992/08/29 19:56:24 $
X *         Filename:  $RCSfile: exfns.c,v $
X *         Revision:  $Revision: 1.2 $
X */
X
X#include <stdio.h>
X
Xint Mayberry = 0;
X
Xdouble opie(x)
X     double x;
X{
X    return x*x + 1.2;
X}
X
Xint andy(x)
X     int x;
X{
X    return x + Mayberry;
X}
X
Xchar * helen(x, y)
X     int x;
X     char * y;
X{
X    static char buf[100];
X
X    sprintf(buf, "%d: %s", x, y);
X
X    Mayberry++;
X
X    return buf;
X}
X
________This_Is_The_END________
if test `wc -c < exfns.c` -ne      480; then
    echo 'shar: exfns.c was damaged during transit (should have been      480 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - exfns.h'
if test -f exfns.h; then echo 'shar: not overwriting exfns.h'; else
sed 's/^X//' << '________This_Is_The_END________' > exfns.h
X/*
X *   Last edited by:  $Author: robt $
X *               on:  $Date: 1992/08/29 19:31:21 $
X *         Filename:  $RCSfile: exfns.h,v $
X *         Revision:  $Revision: 1.1 $
X */
X
Xextern int Mayberry;
Xextern double opie();
Xextern int andy();
Xextern char * helen();
X
________This_Is_The_END________
if test `wc -c < exfns.h` -ne      266; then
    echo 'shar: exfns.h was damaged during transit (should have been      266 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - makefile'
if test -f makefile; then echo 'shar: not overwriting makefile'; else
sed 's/^X//' << '________This_Is_The_END________' > makefile
X# Makefile for perl usersub examples
X# Last edited by:  $Author: robt $
X#             on:  $Date: 1992/08/30 03:20:00 $
X#       Filename:  $RCSfile: makefile,v $
X#       Revision:  $Revision: 1.7 $
X
XCC=cc
X
X.SUFFIXES: .mus $(SUFFIXES)
X.mus.c:
X    mus $*.mus > $*.c
X
X# Path of your perl source goes here.  uperl.o must also be there.
XPERLSRC = /u/robt/src/perl435
XCFLAGS = -I$(PERLSRC)
XLIBS =
X
X
Xall: ex1perl ex2perl ex3perl
X
Xex1perl: $(PERLSRC)/uperl.o exfns.o ex1.o
X    $(CC) $(PERLSRC)/uperl.o exfns.o ex1.o $(LIBS) -o ex1perl
X
Xex2perl: $(PERLSRC)/uperl.o exfns.o ex2.o
X    $(CC) $(PERLSRC)/uperl.o exfns.o ex2.o $(LIBS) -o ex2perl
X
Xex3perl: $(PERLSRC)/uperl.o exfns.o ex3.o
X    $(CC) $(PERLSRC)/uperl.o exfns.o ex3.o $(LIBS) -o ex3perl
X
Xshar:  usub.doc ex[1-3].mus exfns.[ch] makefile extest.pl
X    shar -h usub.shar usub.doc ex[1-3].mus exfns.[ch] makefile extest.pl
X
Xclean:
X    rm -f *.o ex*perl ex[0-9].c
________This_Is_The_END________
if test `wc -c < makefile` -ne      892; then
    echo 'shar: makefile was damaged during transit (should have been      892 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - extest.pl'
if test -f extest.pl; then echo 'shar: not overwriting extest.pl'; else
sed 's/^X//' << '________This_Is_The_END________' > extest.pl
X#  Last edited by:  $Author: robt $
X#              on:  $Date: 1992/08/29 20:09:02 $
X#        Filename:  $RCSfile: extest.pl,v $
X#        Revision:  $Revision: 1.3 $
X#  Run this using the sample perls ex[1-3]perl to see that
X#  things got hooked in correctly.
X
X#print "&opie is defined\n"      if ( defined(&opie) );
X#print "&andy is defined\n"      if ( defined(&andy) );
X#print "&helen is defined\n"     if ( defined(&helen) );
X#print "&otis is defined\n"      if ( defined(&otis) );
X#print "\$Mayberry is defined\n" if ( defined($Mayberry) );
X
Xif ( defined(&opie) ) {
X    print "&opie is defined\n";
X    print "\t&opie(10) = ", &opie(10), "\n";
X} else {
X    print "&opie is not defined\n";
X}
X
X
Xif ( defined(&andy) && defined($Mayberry) ) {
X    print "&andy is defined\n";
X    print "\t&andy(5) = ", &andy(5), "\n";
X    $Mayberry = 7;
X    print "\tAfter changing \$Mayberry to $Mayberry, &andy(5) = ", &andy(5), "\n";
X} else {
X    print "Either &andy or \$Mayberry is not defined\n";
X}
X
X
Xif ( defined(&helen) ) {
X    print "&helen is defined\n";
X    print "\t&helen(3, \"floyd\") = ", &helen(3, "floyd"), "\n";
X    print "\t\$Mayberry = ", $Mayberry, "\n";
X} else {
X    print "&helen is not defined\n";
X}
X
Xif ( defined(&otis) ) {
X    print "&otis is defined\n";
X    print "\t&otis(5) = ", join(' ', &otis(5)), "\n";
X} else {
X    print "&otis is not defined\n";
X}
X
X
X
X
________This_Is_The_END________
if test `wc -c < extest.pl` -ne     1370; then
    echo 'shar: extest.pl was damaged during transit (should have been     1370 bytes)'
fi
fi        ; : end of overwriting check
exit 0
--
-- Rob Torop

+---------------------------------------------------------------------+
| The views expressed here are neither mine nor those of my employer. |
+---------------------------------------------------------------------+