Author Topic: Perl Extension Module  (Read 23481 times)

Support

  • Administrator
  • *****
  • Posts: 22
    • View Profile
Perl Extension Module
« on: April 08, 2015, 09:07:07 AM »
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

  • Administrator
  • *****
  • Posts: 22
    • View Profile
Re: Perl Extension Module
« Reply #1 on: April 08, 2015, 09:09:42 AM »
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

  • Administrator
  • *****
  • Posts: 22
    • View Profile
Re: Perl Extension Module
« Reply #2 on: April 08, 2015, 09:11:33 AM »
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

  • Administrator
  • *****
  • Posts: 22
    • View Profile
Re: Perl Extension Module
« Reply #3 on: April 08, 2015, 10:45:31 AM »
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

  • Administrator
  • *****
  • Posts: 22
    • View Profile
Re: Perl Extension Module
« Reply #4 on: April 08, 2015, 09:41:40 PM »
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

  • Administrator
  • *****
  • Posts: 22
    • View Profile
Re: Perl Extension Module
« Reply #5 on: April 08, 2015, 11:56:17 PM »
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>
« Last Edit: April 09, 2015, 12:08:00 AM by support »