new perlembed.pod:match.c

I didn't see any negative (or positive) feedback on the new version of
the match.c perlembed example I posted in reply to someone's perlbug a
while back.  So, here's a perlembed.pod patch.

p5p-msgid: 199707170355.XAA21370@postman.opengroup.org

1 files changed, 127 insertions, 109 deletions

diff --git a/pod/perlembed.pod b/pod/perlembed.pod
index de10860987..378a7d6435 100644
--- a/pod/perlembed.pod
+++ b/pod/perlembed.pod
@@ -332,155 +332,173 @@ variables and we've simplified our code as well.
 
 =head2 Performing Perl pattern matches and substitutions from your C program
 
-The I<perl_eval_pv()> function lets us evaluate strings of Perl code, so we can
+The I<perl_eval_sv()> function lets us evaluate chunks of Perl code, so we can
 define some functions that use it to "specialize" in matches and
 substitutions: I<match()>, I<substitute()>, and I<matches()>.
 
-   char match(char *string, char *pattern);
+   char match(SV *string, char *pattern);
 
 Given a string and a pattern (e.g., C<m/clasp/> or C</\b\w*\b/>, which
 in your C program might appear as "/\\b\\w*\\b/"), match()
 returns 1 if the string matches the pattern and 0 otherwise.
 
-   int substitute(char *string[], char *pattern);
+   int substitute(SV **string, char *pattern);
 
-Given a pointer to a string and an C<=~> operation (e.g.,
+Given a pointer to an C<SV> and an C<=~> operation (e.g.,
 C<s/bob/robert/g> or C<tr[A-Z][a-z]>), substitute() modifies the string
-according to the operation, returning the number of substitutions
+within the C<AV> at according to the operation, returning the number of substitutions
 made.
 
-   int matches(char *string, char *pattern, char **matches[]);
+   int matches(SV *string, char *pattern, AV **matches);
 
-Given a string, a pattern, and a pointer to an empty array of strings,
+Given an C<SV>, a pattern, and a pointer to an empty C<AV>,
 matches() evaluates C<$string =~ $pattern> in an array context, and
-fills in I<matches> with the array elements (allocating memory as it
-does so), returning the number of matches found.
+fills in I<matches> with the array elements, returning the number of matches found.
 
 Here's a sample program, I<match.c>, that uses all three (long lines have
 been wrapped here):
 
-   #include <EXTERN.h>
-   #include <perl.h>
-
-   static PerlInterpreter *my_perl;
-
-   /** match(string, pattern)
-   **
-   ** Used for matches in a scalar context.
-   **
-   ** Returns 1 if the match was successful; 0 otherwise.
-   **/
-   char match(char *string, char *pattern)
-   {
-     char *command;
-     command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37);
-     sprintf(command, "$string = '%s'; $return = $string =~ %s",
-                      string, pattern);
-     perl_eval_pv(command, TRUE);
-     free(command);
-     return SvIV(perl_get_sv("return", FALSE));
-   }
-   /** substitute(string, pattern)
-   **
-   ** Used for =~ operations that modify their left-hand side (s/// and tr///)
-   **
-   ** Returns the number of successful matches, and
-   ** modifies the input string if there were any.
-   **/
-   int substitute(char *string[], char *pattern)
-   {
-     char *command;
-     STRLEN length;
-     command = malloc(sizeof(char) * strlen(*string) + strlen(pattern) + 35);
-     sprintf(command, "$string = '%s'; $ret = ($string =~ %s)",
-                      *string, pattern);
-     perl_eval_pv(command, TRUE);
-     free(command);
-     *string = SvPV(perl_get_sv("string", FALSE), length);
-     return SvIV(perl_get_sv("ret", FALSE));
-   }
-   /** matches(string, pattern, matches)
-   **
-   ** Used for matches in an array context.
-   **
-   ** Returns the number of matches,
-   ** and fills in **matches with the matching substrings (allocates memory!)
-   **/
-   int matches(char *string, char *pattern, char **match_list[])
-   {
-     char *command;
-     SV *current_match;
-     AV *array;
+ #include <EXTERN.h>
+ #include <perl.h>
+ 
+ /** my_perl_eval_sv(code, error_check)
+ ** kinda like perl_eval_sv(), 
+ ** but we pop the return value off the stack 
+ **/
+ SV* my_perl_eval_sv(SV *sv, I32 croak_on_error)
+ {
+     dSP;
+     SV* retval;
+ 
+     PUSHMARK(sp);
+     perl_eval_sv(sv, G_SCALAR);
+ 
+     SPAGAIN;
+     retval = POPs;
+     PUTBACK;
+ 
+     if (croak_on_error && SvTRUE(GvSV(errgv)))
+ 	croak(SvPVx(GvSV(errgv), na));
+ 
+     return retval;
+ }
+ 
+ /** match(string, pattern)
+ **
+ ** Used for matches in a scalar context.
+ **
+ ** Returns 1 if the match was successful; 0 otherwise.
+ **/
+ 
+ I32 match(SV *string, char *pattern)
+ {
+     SV *command = newSV(0), *retval;
+ 
+     sv_setpvf(command, "my $string = '%s'; $string =~ %s",
+ 	      SvPV(string,na), pattern);
+ 
+     retval = my_perl_eval_sv(command, TRUE);
+     SvREFCNT_dec(command);
+ 
+     return SvIV(retval);
+ }
+ 
+ /** substitute(string, pattern)
+ **
+ ** Used for =~ operations that modify their left-hand side (s/// and tr///)
+ **
+ ** Returns the number of successful matches, and
+ ** modifies the input string if there were any.
+ **/
+ 
+ I32 substitute(SV **string, char *pattern)
+ {
+     SV *command = newSV(0), *retval;
+ 
+     sv_setpvf(command, "$string = '%s'; ($string =~ %s)",
+ 	      SvPV(*string,na), pattern);
+ 
+     retval = my_perl_eval_sv(command, TRUE);
+     SvREFCNT_dec(command);
+ 
+     *string = perl_get_sv("string", FALSE);
+     return SvIV(retval);
+ }
+ 
+ /** matches(string, pattern, matches)
+ **
+ ** Used for matches in an array context.
+ **
+ ** Returns the number of matches,
+ ** and fills in **matches with the matching substrings
+ **/
+ 
+ I32 matches(SV *string, char *pattern, AV **match_list)
+ {
+     SV *command = newSV(0);
      I32 num_matches;
-     STRLEN length;
-     int i;
-     command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38);
-     sprintf(command, "$string = '%s'; @array = ($string =~ %s)",
-                      string, pattern);
-     perl_eval_pv(command, TRUE);
-     free(command);
-     array = perl_get_av("array", FALSE);
-     num_matches = av_len(array) + 1; /** assume $[ is 0 **/
-     *match_list = (char **) malloc(sizeof(char *) * num_matches);
-     for (i = 0; i <= num_matches; i++) {
-       current_match = av_shift(array);
-       (*match_list)[i] = SvPV(current_match, length);
-     }
+ 
+     sv_setpvf(command, "my $string = '%s'; @array = ($string =~ %s)",
+ 	      SvPV(string,na), pattern);
+ 
+     my_perl_eval_sv(command, TRUE);
+     SvREFCNT_dec(command);
+ 
+     *match_list = perl_get_av("array", FALSE);
+     num_matches = av_len(*match_list) + 1; /** assume $[ is 0 **/
+ 
      return num_matches;
-   }
-   main (int argc, char **argv, char **env)
-   {
+ }
+ 
+ main (int argc, char **argv, char **env)
+ {
+     PerlInterpreter *my_perl = perl_alloc();
      char *embedding[] = { "", "-e", "0" };
-     char *text, **match_list;
-     int num_matches, i;
-     int j;
-     my_perl = perl_alloc();
-     perl_construct( my_perl );
+     AV *match_list;
+     I32 num_matches, i;
+     SV *text = newSV(0);
+ 
+     perl_construct(my_perl);
      perl_parse(my_perl, NULL, 3, embedding, NULL);
-     perl_run(my_perl);
-
-     text = (char *) malloc(sizeof(char) * 486); /** A long string follows! **/
-     sprintf(text, "%s", "When he is at a convenience store and the bill \
-     comes to some amount like 76 cents, Maynard is aware that there is \
-     something he *should* do, something that will enable him to get back \
-     a quarter, but he has no idea *what*.  He fumbles through his red \
-     squeezey changepurse and gives the boy three extra pennies with his \
-     dollar, hoping that he might luck into the correct amount.  The boy \
-     gives him back two of his own pennies and then the big shiny quarter \
-     that is his prize. -RICHH");
+ 
+     sv_setpv(text, "When he is at a convenience store and the bill comes to some amount like 76 cents, Maynard is aware that there is something he *should* do, something that will enable him to get back a quarter, but he has no idea *what*.  He fumbles through his red squeezey changepurse and gives the boy three extra pennies with his dollar, hoping that he might luck into the correct amount.  The boy gives him back two of his own pennies and then the big shiny quarter that is his prize. -RICHH");
+ 
      if (match(text, "m/quarter/")) /** Does text contain 'quarter'? **/
-       printf("match: Text contains the word 'quarter'.\n\n");
+ 	printf("match: Text contains the word 'quarter'.\n\n");
      else
-       printf("match: Text doesn't contain the word 'quarter'.\n\n");
+ 	printf("match: Text doesn't contain the word 'quarter'.\n\n");
+ 
      if (match(text, "m/eighth/")) /** Does text contain 'eighth'? **/
-       printf("match: Text contains the word 'eighth'.\n\n");
+ 	printf("match: Text contains the word 'eighth'.\n\n");
      else
-       printf("match: Text doesn't contain the word 'eighth'.\n\n");
+ 	printf("match: Text doesn't contain the word 'eighth'.\n\n");
+ 
      /** Match all occurrences of /wi../ **/
      num_matches = matches(text, "m/(wi..)/g", &match_list);
      printf("matches: m/(wi..)/g found %d matches...\n", num_matches);
+ 
      for (i = 0; i < num_matches; i++)
-       printf("match: %s\n", match_list[i]);
+ 	printf("match: %s\n", SvPV(*av_fetch(match_list, i, FALSE),na));
      printf("\n");
-     for (i = 0; i < num_matches; i++) {
-       free(match_list[i]);
-     }
-     free(match_list);
+ 
      /** Remove all vowels from text **/
      num_matches = substitute(&text, "s/[aeiou]//gi");
      if (num_matches) {
-       printf("substitute: s/[aeiou]//gi...%d substitutions made.\n",
-              num_matches);
-       printf("Now text is: %s\n\n", text);
+ 	printf("substitute: s/[aeiou]//gi...%d substitutions made.\n",
+ 	       num_matches);
+ 	printf("Now text is: %s\n\n", SvPV(text,na));
      }
+ 
      /** Attempt a substitution **/
      if (!substitute(&text, "s/Perl/C/")) {
-       printf("substitute: s/Perl/C...No substitution made.\n\n");
+ 	printf("substitute: s/Perl/C...No substitution made.\n\n");
      }
-     free(text);
+ 
+     SvREFCNT_dec(text);
+     perl_destruct_level = 1;
      perl_destruct(my_perl);
      perl_free(my_perl);
-   }
+ }
 
 which produces the output (again, long lines have been wrapped here)