Perl Extension Module

[Support]

I'm done with the Perl extension module in its current form. I see no purpose going through all the work of calling Perl functions from C directly and having to do all the crazy low level stack stuff. The Perl Eval function does everything I need at the moment and works like the TinyScheme extension module.

DECLARE SUB pl_Init ALIAS "pl_Init" LIB "sbperl"
DECLARE SUB pl_Eval ALIAS "pl_Eval" LIB "sbperl"
DECLARE SUB pl_GetInt ALIAS "pl_GetInt" LIB "sbperl"
DECLARE SUB pl_GetDbl ALIAS "pl_GetDbl" LIB "sbperl"
DECLARE SUB pl_GetStr ALIAS "pl_GetStr" LIB "sbperl"
DECLARE SUB pl_Destroy ALIAS "pl_Destroy" LIB "sbperl"

pl_Init

pl_code = """
sub Average{
   # get total number of arguments passed.
   $n = scalar(@_);
   $sum = 0;

   foreach $item (@_){
      $sum += $item;
   }
   $average = $sum / $n;

   return $average;
}
"""
pl_Eval pl_code
pl_Eval "$num = Average(10, 20, 30);"
PRINT pl_GetInt("num"),"\n"

pl_Destroy
 

jrs@laptop:~/sb/sb22/test$ scriba perlfunc.sb
20
jrs@laptop:~/sb/sb22/test$

[Support]

Here is an example of getting the SB filedesc.sb script file info by calling a Perl function.

DECLARE SUB pl_Init ALIAS "pl_Init" LIB "sbperl"
DECLARE SUB pl_Eval ALIAS "pl_Eval" LIB "sbperl"
DECLARE SUB pl_GetInt ALIAS "pl_GetInt" LIB "sbperl"
DECLARE SUB pl_GetDbl ALIAS "pl_GetDbl" LIB "sbperl"
DECLARE SUB pl_GetStr ALIAS "pl_GetStr" LIB "sbperl"
DECLARE SUB pl_Destroy ALIAS "pl_Destroy" LIB "sbperl"

pl_Init

pl_code = """
my $file = "filedesc.sb";
my (@description, $size);
if (-e $file)
{
   push @description, 'binary' if (-B _);
   push @description, 'a socket' if (-S _);
   push @description, 'a text file' if (-T _);
   push @description, 'a block special file' if (-b _);
   push @description, 'a character special file' if (-c _);
   push @description, 'a directory' if (-d _);
   push @description, 'executable' if (-x _);
   push @description, (($size = -s _)) ? "$size bytes" : 'empty';
   print "$file is ", join(', ',@description),"\n";
}
"""
pl_Eval pl_code

pl_Destroy
 

jrs@laptop:~/sb/sb22/test$ scriba filedesc.sb
filedesc.sb is a text file, 898 bytes
jrs@laptop:~/sb/sb22/test$ ls -l filedesc.sb
-rw-rw-r-- 1 jrs jrs 898 Apr  8 00:15 filedesc.sb
jrs@laptop:~/sb/sb22/test$

[Support]

Here is the current Script BASIC interface.c (sbperl.so) extension module source.

Perl Embedding API Documentation

/* Perl - Script BASIC extension module

UXLIBS: -lperl

*/

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <math.h>
#include <time.h>
#include "../../basext.h"
#include "cbasic.h"

#include <EXTERN.h>
#include <perl.h>

static PerlInterpreter *my_perl;

/****************************
 Extension Module Functions
****************************/

besVERSION_NEGOTIATE
  RETURN_FUNCTION((int)INTERFACE_VERSION);
besEND

besSUB_START
  DIM AS long PTR p;
  besMODULEPOINTER = besALLOC(sizeof(long));
  IF (besMODULEPOINTER EQ NULL) THEN_DO RETURN_FUNCTION(0);
  p = (long PTR)besMODULEPOINTER;
  RETURN_FUNCTION(0);
besEND

besSUB_FINISH
  DIM AS long PTR p;
  p = (long PTR)besMODULEPOINTER;
  IF (p EQ NULL) THEN_DO RETURN_FUNCTION(0);
  RETURN_FUNCTION(0);
besEND


/****************
 Perl Functions
****************/

besFUNCTION(pl_Init)
  DIM AS char *embedding[] = { "", "-e", "0" };
  my_perl = perl_alloc();
  perl_construct(my_perl);
  perl_parse(my_perl, NULL, 3, embedding, NULL);
  perl_run(my_perl);
  besRETURN_LONG(my_perl);
besEND

besFUNCTION(pl_Eval)
  DIM AS const char PTR cmdstr;
  besARGUMENTS("z")
    AT cmdstr
  besARGEND
  eval_pv(cmdstr, TRUE);
  besRETURNVALUE = NULL;
besEND

besFUNCTION(pl_GetInt)
  DIM AS const char PTR cmdstr;
  DIM AS int rtnval;
  besARGUMENTS("z")
    AT cmdstr
  besARGEND
  rtnval = SvIV(get_sv(cmdstr, FALSE));
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(pl_GetDbl)
  DIM AS const char PTR cmdstr;
  DIM AS double rtnval;
  besARGUMENTS("z")
    AT cmdstr
  besARGEND
  rtnval = SvNV(get_sv(cmdstr, FALSE));
  besRETURN_DOUBLE(rtnval);
besEND

besFUNCTION(pl_GetStr)
  DIM AS const char PTR cmdstr;
  DIM AS char PTR rtnval;
  DIM AS STRLEN n_a;
  besARGUMENTS("z")
    AT cmdstr
  besARGEND
  rtnval = SvPV(get_sv(cmdstr, FALSE), n_a);
  besRETURN_STRING(rtnval);
besEND

besFUNCTION(pl_Destroy)
  perl_destruct(my_perl);
  perl_free(my_perl);
  besRETURNVALUE = NULL;
besEND
 

[Support]

Perl has an console interactive (debugger) mode you can play with.


jrs@laptop:~/sb/sb22/test$ perl -d -e 1

Loading DB routines from perl5db.pl version 1.39_10
Editor support available.

Enter h or 'h h' for help, or 'man perldebug' for more help.

main::(-e:1):   1
  DB<1> h
List/search source lines:               Control script execution:
  l [ln|sub]  List source code            T           Stack trace
  - or .      List previous/current line  s [expr]    Single step [in expr]
  v [line]    View around line            n [expr]    Next, steps over subs
  f filename  View source in file         <CR/Enter>  Repeat last n or s
  /pattern/ ?patt?   Search forw/backw    r           Return from subroutine
  M           Show module versions        c [ln|sub]  Continue until position
Debugger controls:                        L           List break/watch/actions
  o [...]     Set debugger options        t [n] [expr] Toggle trace [max depth] ][trace expr]
  <[<]|{[{]|>[>] [cmd] Do pre/post-prompt b [ln|event|sub] [cnd] Set breakpoint
  ! [N|pat]   Redo a previous command     B ln|*      Delete a/all breakpoints
  H [-num]    Display last num commands   a [ln] cmd  Do cmd before line
  = [a val]   Define/list an alias        A ln|*      Delete a/all actions
  h [db_cmd]  Get help on command         w expr      Add a watch expression
  h h         Complete help page          W expr|*    Delete a/all watch exprs
  |[|]db_cmd  Send output to pager        ![!] syscmd Run cmd in a subprocess
  q or ^D     Quit                        R           Attempt a restart
Data Examination:     expr     Execute perl code, also see: s,n,t expr
  x|m expr       Evals expr in list context, dumps the result or lists methods.
  p expr         Print expression (uses script's current package).
  S [[!]pat]     List subroutine names [not] matching pattern
  V [Pk [Vars]]  List Variables in Package.  Vars can be ~pattern or !pattern.
  X [Vars]       Same as "V current_package [Vars]".  i class inheritance tree.
  y [n [Vars]]   List lexicals in higher scope <n>.  Vars same as V.
  e     Display thread id     E Display all thread ids.
For more help, type h cmd_letter, or run man perldebug for all docs.
  DB<1>

[Support]

The following is a Perl example of using regular expression parsing. (regx)

DECLARE SUB pl_Init ALIAS "pl_Init" LIB "sbperl"
DECLARE SUB pl_Eval ALIAS "pl_Eval" LIB "sbperl"
DECLARE SUB pl_GetInt ALIAS "pl_GetInt" LIB "sbperl"
DECLARE SUB pl_GetDbl ALIAS "pl_GetDbl" LIB "sbperl"
DECLARE SUB pl_GetStr ALIAS "pl_GetStr" LIB "sbperl"
DECLARE SUB pl_Destroy ALIAS "pl_Destroy" LIB "sbperl"

pl_Init

pl_code = """
sub test($$)
        {
        my $lookfor = shift;
        my $string = shift;
        print "\n$lookfor ";
        if($string =~ m/($lookfor)/)
                {
                print " is in ";
                }
        else
                {
                print " is NOT in ";
                }
        print "$string.";
        if(defined($1))
                {
                print "      <$1>";
                }
        print "\n";
        }

test("st.v.", "steve was here");
test("st.v.", "kitchen stove");
test("st.v.", "kitchen store");
"""
PRINTNL

pl_Eval pl_code

pl_Destroy
 
Output


jrs@laptop:~/sb/sb22/test$ time scriba perlmatch.sb


st.v.  is in steve was here.      <steve>

st.v.  is in kitchen stove.      <stove>

st.v.  is NOT in kitchen store.

real   0m0.004s
user   0m0.000s
sys   0m0.004s
jrs@laptop:~/sb/sb22/test$

[Support]

Here is the above Perl example using the Script BASIC re (regx) extension module. This example is in 32 Windows XP as re seq faults under 64 bit. 

IMPORT re.bas

SUB test(regx, target)
  IF re::match(target,regx) THEN
    PRINT regx," is in ",target,"      <",re::dollar(0),">\n"
  ELSE
    PRINT regx," is NOT in ",target,"\n"
  END IF
END SUB

test("st.v.", "steve was here")
test("st.v.", "kitchen stove")
test("st.v.", "kitchen store")

PRINTNL  
 
Output


C:\sb22\test>scriba testregx.sb
st.v. is in steve was here      <steve>
st.v. is in kitchen stove      <stove>
st.v. is NOT in kitchen store


C:\sb22\test>