Open Forum > What's New

Perl Extension Module

(1/2) > >>

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.


--- Code: Script BASIC ---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_codepl_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.


--- Code: Script BASIC ---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


--- Code: C ---/* 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)


--- Code: Script BASIC ---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$

Navigation

[0] Message Index

[#] Next page