Writing a Perl Core Feature - part 7: Support functions

Index | < Prev | Next >

So far in this series we've seen several modifications and small additions, to add the required bits and pieces for our new feature to various parts of the perl interpreter. Often when adding anything but the very smallest and simplest of features or changes, it becomes necessary not just to modify existing things, but to add some new support functions as well.

For example, adding the isa feature required adding a new function to actually implement the bulk of the operation, which is then called from the pp_isa opcode function. This helper function was added into universal.c in this commit: (github.com/Perl/perl5).

--- a/universal.c
+++ b/universal.c
@@ -187,6 +187,74 @@ Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len,
     return sv_derived_from_svpvn(sv, NULL, name, len, flags);
 }
 
+/*
+=for apidoc sv_isa_sv
+
+Returns a boolean indicating whether the SV is an object reference and is
+derived from the specified class, respecting any C<isa()> method overloading
+it may have. Returns false if C<sv> is not a reference to an object, or is
+not derived from the specified class.
...
+
+=cut
+
+*/
+
+bool
+Perl_sv_isa_sv(pTHX_ SV *sv, SV *namesv)
+{
+    GV *isagv;
+
+    PERL_ARGS_ASSERT_SV_ISA_SV;
+
+    if(!SvROK(sv) || !SvOBJECT(SvRV(sv)))
+        return FALSE;
+
...
+    return sv_derived_from_sv(sv, namesv, 0);
+}
+
 /*
 =for apidoc sv_does_sv

Like all good helper functions, this one is named beginning with a Perl_ prefix and takes as its first parameter the pTHX_ macro. To make the function properly visible to other code within the interpreter, an entry needed adding to the embed.fnc file which lists all of the functions. (github.com/Perl/perl5).

--- a/embed.fnc
+++ b/embed.fnc
@@ -1777,6 +1777,7 @@ ApdR      |bool   |sv_derived_from_sv|NN SV* sv|NN SV *namesv|U32 flags
 ApdR   |bool   |sv_derived_from_pv|NN SV* sv|NN const char *const name|U32 flags
 ApdR   |bool   |sv_derived_from_pvn|NN SV* sv|NN const char *const name \
                                     |const STRLEN len|U32 flags
+ApdRx  |bool   |sv_isa_sv      |NN SV* sv|NN SV* namesv
 ApdR   |bool   |sv_does        |NN SV* sv|NN const char *const name
 ApdR   |bool   |sv_does_sv     |NN SV* sv|NN SV* namesv|U32 flags
 ApdR   |bool   |sv_does_pv     |NN SV* sv|NN const char *const name|U32 flags

This file stores pipe-separated columns, containing:

• A set of flags - in this case marking an API function (A), having the Perl_ prefix (p), with documentation (d), whose return value must not be ignored (R) and is currently experimental (x)
• The return type
• The name
• Argument types in all remaining columns; where NN prefixes an argument which must not be passed as NULL

For our new banana feature lets now think of some semantics. Perhaps, given the example code we saw yesterday, it should return a new string built from its argument. For arbitrary reasons of having something interesting yet unlikely in practice, lets make it return a ROT13 transformed version.

Lets now add a helper function to do this - something to construct a new string SV containing the ROT13'ed transformation of the given input. We'll begin by picking a new name for this new function, and adding a definition line into the embed.fnc list, and running the regen/embed.pl regeneration script:

leo@shy:~/src/bleadperl/perl [git]
$ nvim embed.fnc 

leo@shy:~/src/bleadperl/perl [git]
$ git diff embed.fnc
diff --git a/embed.fnc b/embed.fnc
index eb7b47601a..74946566e7 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1488,6 +1488,7 @@ ApdR      |SV*    |newSVuv        |const UV u
 ApdR   |SV*    |newSVnv        |const NV n
 ApdR   |SV*    |newSVpv        |NULLOK const char *const s|const STRLEN len
 ApdR   |SV*    |newSVpvn       |NULLOK const char *const buffer|const STRLEN len
+ApdR   |SV*    |newSVpvn_rot13 |NN const char *const s|const STRLEN len
 ApdR   |SV*    |newSVpvn_flags |NULLOK const char *const s|const STRLEN len|const U32 flags
 ApdR   |SV*    |newSVhek       |NULLOK const HEK *const hek
 ApdR   |SV*    |newSVpvn_share |NULLOK const char* s|I32 len|U32 hash

leo@shy:~/src/bleadperl/perl [git]
$ perl regen/embed.pl 
Changed: proto.h embed.h

Take a look now at the changes it's made.

• A new macro in embed.h which calls the full Perl_-prefixed function name from its shorter alias. The macro makes sure to pass in the aTHX_ parameter, meaning we don't have to remember that all the time
• A prototype and an arguments assertion macro for the function in proto.h

To actually implement this function we should pick a file to put it in. Since it's creating a new SV, the file sv.c seems reasonable. For neatness we'll put it right next to the other newSVpv* functions, in the same order as the list in embed.fnc:

leo@shy:~/src/bleadperl/perl [git]
$ nvim sv.c

leo@shy:~/src/bleadperl/perl [git]
$ git diff sv.c
diff --git a/sv.c b/sv.c
index e54d0a078f..156e64e879 100644
--- a/sv.c
+++ b/sv.c
@@ -9397,6 +9397,43 @@ Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
     return sv;
 }
 
+/*
+=for apidoc newSVpvn_rot13
+
+Creates a new SV and copies a string into it by transforming letters by the
+ROT13 algorithm, and copying other bytes literally. The string may contain
+C<NUL> characters and other binary data. The reference count for the new SV
+is set to 1.
+
+=cut
+*/
+
+SV *
+Perl_newSVpvn_rot13(pTHX_ const char *const s, const STRLEN len)
+{
+    char *dp;
+    const char *sp = s, *send = s + len;
+    SV *sv = newSV(len);
+
+    dp = SvPVX(sv);
+    while(sp < send) {
+        char c = *sp;
+        if(isLOWER(c))
+            *dp = 'a' + (c - 'a' + 13) % 26;
+        else if(isUPPER(c))
+            *dp = 'A' + (c - 'A' + 13) % 26;
+        else
+            *dp = c;
+
+        sp++; dp++;
+    }
+
+    *dp = '\0';
+    SvPOK_on(sv);
+    SvCUR_set(sv, len);
+    return sv;
+}
+
 /*
 =for apidoc newSVhek

I don't want to spend a large amount of time or space in this post to explain the whole function, but as a brief summary,

1. newSV() creates a new SV with a string buffer big enough to store the content (it internally adds 1 more to accomodate the terminating NUL)
2. The pointers sp and dp are initialised to point into the source and destination string buffers
3. Characters are copied one at a time; performing the ROT13 algorithm on lower or uppercase letters and passing anything else transparently
4. The terminating NUL is appended
5. The current string size and stringiness flag are set on the new SV, which is then returned

If we run the porting tests again now, we'll find one gets upset:

leo@shy:~/src/bleadperl/perl [git]
$ make test_porting
...
porting/args_assert.t ..... 1/? # Failed test 2 - PERL_ARGS_ASSERT_NEWSVPVN_ROT13 is 
declared but not used at porting/args_assert.t line 64

This test is unhappy because it didn't find any code that actually called the argument-asserting macro which the regeneration script added to proto.h. This is the macro that asserts on the types of arguments to the function. We can fix that by remembering to use it in the function's definition:

leo@shy:~/src/bleadperl/perl [git]
$ nvim sv.c

leo@shy:~/src/bleadperl/perl [git]
$ git diff sv.c
diff --git a/sv.c b/sv.c
index e54d0a078f..d63c8a7bbb 100644
--- a/sv.c
+++ b/sv.c
...
+SV *
+Perl_newSVpvn_rot13(pTHX_ const char *const s, const STRLEN len)
+{
+    char *dp;
+    const char *sp = s, *send = s + len;
+    SV *sv;
+
+    PERL_ARGS_ASSERT_NEWSVPVN_ROT13;
+
+    sv = newSV(len);
+
+    dp = SvPVX(sv);
...

leo@shy:~/src/bleadperl/perl [git]
$ make test_porting
...
Result: PASS

As core functions go this one is actually pretty terrible. It presumes ASCII (and doesn't work properly on EBCDIC platforms), and requires careful handling in the caller to set the UTF8 flag if required. But overall it's at least good enough for demonstration purposes for our feature. In the next part we'll hook this function up with the opcode implementation and finally see our new feature in action.

Index | < Prev | Next >