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.

Code: Script BASIC

1. DECLARE SUB pl_Init ALIAS "pl_Init" LIB "sbperl"
2. DECLARE SUB pl_Eval ALIAS "pl_Eval" LIB "sbperl"
3. DECLARE SUB pl_GetInt ALIAS "pl_GetInt" LIB "sbperl"
4. DECLARE SUB pl_GetDbl ALIAS "pl_GetDbl" LIB "sbperl"
5. DECLARE SUB pl_GetStr ALIAS "pl_GetStr" LIB "sbperl"
6. DECLARE SUB pl_Destroy ALIAS "pl_Destroy" LIB "sbperl"
7.  
8. pl_Init
9.  
10. pl_code = """
11. sub Average{
12.   # get total number of arguments passed.
13.   $n = scalar(@_);
14.   $sum = 0;
15.  
16.   foreach $item (@_){
17.      $sum += $item;
18.   }
19.   $average = $sum / $n;
20.  
21.   return $average;
22. }
23. """
24. pl_Eval pl_code
25. pl_Eval "$num = Average(10, 20, 30);"
26. PRINT pl_GetInt("num"),"\n"
27.  
28. pl_Destroy
29.  

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

1. DECLARE SUB pl_Init ALIAS "pl_Init" LIB "sbperl"
2. DECLARE SUB pl_Eval ALIAS "pl_Eval" LIB "sbperl"
3. DECLARE SUB pl_GetInt ALIAS "pl_GetInt" LIB "sbperl"
4. DECLARE SUB pl_GetDbl ALIAS "pl_GetDbl" LIB "sbperl"
5. DECLARE SUB pl_GetStr ALIAS "pl_GetStr" LIB "sbperl"
6. DECLARE SUB pl_Destroy ALIAS "pl_Destroy" LIB "sbperl"
7.  
8. pl_Init
9.  
10. pl_code = """
11. my $file = "filedesc.sb";
12. my (@description, $size);
13. if (-e $file)
14. {
15.   push @description, 'binary' if (-B _);
16.   push @description, 'a socket' if (-S _);
17.   push @description, 'a text file' if (-T _);
18.   push @description, 'a block special file' if (-b _);
19.   push @description, 'a character special file' if (-c _);
20.   push @description, 'a directory' if (-d _);
21.   push @description, 'executable' if (-x _);
22.   push @description, (($size = -s _)) ? "$size bytes" : 'empty';
23.   print "$file is ", join(', ',@description),"\n";
24. }
25. """
26. pl_Eval pl_code
27.  
28. pl_Destroy
29.  

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

1. /* Perl - Script BASIC extension module
2.  
3. UXLIBS: -lperl
4.  
5. */
6.  
7. #include <stdio.h>
8. #include <stdlib.h>
9. #include <string.h>
10. #include <ctype.h>
11. #include <math.h>
12. #include <time.h>
13. #include "../../basext.h"
14. #include "cbasic.h"
15.  
16. #include <EXTERN.h>
17. #include <perl.h>
18.  
19. static PerlInterpreter *my_perl;
20.  
21. /****************************
22.  Extension Module Functions
23. ****************************/
24.  
25. besVERSION_NEGOTIATE
26.   RETURN_FUNCTION((int)INTERFACE_VERSION);
27. besEND
28.  
29. besSUB_START
30.   DIM AS long PTR p;
31.   besMODULEPOINTER = besALLOC(sizeof(long));
32.   IF (besMODULEPOINTER EQ NULL) THEN_DO RETURN_FUNCTION(0);
33.   p = (long PTR)besMODULEPOINTER;
34.   RETURN_FUNCTION(0);
35. besEND
36.  
37. besSUB_FINISH
38.   DIM AS long PTR p;
39.   p = (long PTR)besMODULEPOINTER;
40.   IF (p EQ NULL) THEN_DO RETURN_FUNCTION(0);
41.   RETURN_FUNCTION(0);
42. besEND
43.  
44.  
45. /****************
46.  Perl Functions
47. ****************/
48.  
49. besFUNCTION(pl_Init)
50.   DIM AS char *embedding[] = { "", "-e", "0" };
51.   my_perl = perl_alloc();
52.   perl_construct(my_perl);
53.   perl_parse(my_perl, NULL, 3, embedding, NULL);
54.   perl_run(my_perl);
55.   besRETURN_LONG(my_perl);
56. besEND
57.  
58. besFUNCTION(pl_Eval)
59.   DIM AS const char PTR cmdstr;
60.   besARGUMENTS("z")
61.     AT cmdstr
62.   besARGEND
63.   eval_pv(cmdstr, TRUE);
64.   besRETURNVALUE = NULL;
65. besEND
66.  
67. besFUNCTION(pl_GetInt)
68.   DIM AS const char PTR cmdstr;
69.   DIM AS int rtnval;
70.   besARGUMENTS("z")
71.     AT cmdstr
72.   besARGEND
73.   rtnval = SvIV(get_sv(cmdstr, FALSE));
74.   besRETURN_LONG(rtnval);
75. besEND
76.  
77. besFUNCTION(pl_GetDbl)
78.   DIM AS const char PTR cmdstr;
79.   DIM AS double rtnval;
80.   besARGUMENTS("z")
81.     AT cmdstr
82.   besARGEND
83.   rtnval = SvNV(get_sv(cmdstr, FALSE));
84.   besRETURN_DOUBLE(rtnval);
85. besEND
86.  
87. besFUNCTION(pl_GetStr)
88.   DIM AS const char PTR cmdstr;
89.   DIM AS char PTR rtnval;
90.   DIM AS STRLEN n_a;
91.   besARGUMENTS("z")
92.     AT cmdstr
93.   besARGEND
94.   rtnval = SvPV(get_sv(cmdstr, FALSE), n_a);
95.   besRETURN_STRING(rtnval);
96. besEND
97.  
98. besFUNCTION(pl_Destroy)
99.   perl_destruct(my_perl);
100.   perl_free(my_perl);
101.   besRETURNVALUE = NULL;
102. besEND
103.  

[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

1. DECLARE SUB pl_Init ALIAS "pl_Init" LIB "sbperl"
2. DECLARE SUB pl_Eval ALIAS "pl_Eval" LIB "sbperl"
3. DECLARE SUB pl_GetInt ALIAS "pl_GetInt" LIB "sbperl"
4. DECLARE SUB pl_GetDbl ALIAS "pl_GetDbl" LIB "sbperl"
5. DECLARE SUB pl_GetStr ALIAS "pl_GetStr" LIB "sbperl"
6. DECLARE SUB pl_Destroy ALIAS "pl_Destroy" LIB "sbperl"
7.  
8. pl_Init
9.  
10. pl_code = """
11. sub test($$)
12.         {
13.         my $lookfor = shift;
14.         my $string = shift;
15.         print "\n$lookfor ";
16.         if($string =~ m/($lookfor)/)
17.                 {
18.                 print " is in ";
19.                 }
20.         else
21.                 {
22.                 print " is NOT in ";
23.                 }
24.         print "$string.";
25.         if(defined($1))
26.                 {
27.                 print "      <$1>";
28.                 }
29.         print "\n";
30.         }
31.  
32. test("st.v.", "steve was here");
33. test("st.v.", "kitchen stove");
34. test("st.v.", "kitchen store");
35. """
36. PRINTNL
37.  
38. pl_Eval pl_code
39.  
40. pl_Destroy
41.  

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. 

Code: Script BASIC

1. IMPORT re.bas
2.  
3. SUB test(regx, target)
4.   IF re::match(target,regx) THEN
5.     PRINT regx," is in ",target,"      <",re::dollar(0),">\n"
6.   ELSE
7.     PRINT regx," is NOT in ",target,"\n"
8.   END IF
9. END SUB
10.  
11. test("st.v.", "steve was here")
12. test("st.v.", "kitchen stove")
13. test("st.v.", "kitchen store")
14.  
15. PRINTNL  
16.  

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>