Add the `isa` operator

Adds a new infix operator named `isa`, with the semantics that

  $x isa SomeClass

is true if and only if `$x` is a blessed object reference that is either
`SomeClass` directly, or includes the class somewhere in its @ISA
hierarchy. It is false without warning or error for non-references or
non-blessed references.

This operator respects `->isa` method overloading, and is intended to
replace boilerplate code such as

  use Scalar::Util 'blessed';

  blessed($x) and $x->isa("SomeClass")

diff --git a/MANIFEST b/MANIFEST
index 77c6754..387ec38 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5815,6 +5815,7 @@ t/op/index.t                      See if index works
 t/op/index_thr.t               See if index works in another thread
 t/op/infnan.t                  See if inf/nan work
 t/op/int.t                     See if int works
+t/op/isa.t                     See if isa works
 t/op/join.t                    See if join works
 t/op/kill0.t                   See if kill works
 t/op/kill0_child               Process tree script that is kill()ed

diff --git a/embed.fnc b/embed.fnc
index 412d4f6..3abf957 100644 (file)
--- 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

diff --git a/embed.h b/embed.h
index 70caca1..21d26d6 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -600,6 +600,7 @@
 #define sv_inc_nomg(a)         Perl_sv_inc_nomg(aTHX_ a)
 #define sv_insert_flags(a,b,c,d,e,f)   Perl_sv_insert_flags(aTHX_ a,b,c,d,e,f)
 #define sv_isa(a,b)            Perl_sv_isa(aTHX_ a,b)
+#define sv_isa_sv(a,b)         Perl_sv_isa_sv(aTHX_ a,b)
 #define sv_isobject(a)         Perl_sv_isobject(aTHX_ a)
 #ifndef NO_MATHOMS
 #define sv_iv(a)               Perl_sv_iv(aTHX_ a)
@@ -1204,6 +1205,7 @@
 #define ck_glob(a)             Perl_ck_glob(aTHX_ a)
 #define ck_grep(a)             Perl_ck_grep(aTHX_ a)
 #define ck_index(a)            Perl_ck_index(aTHX_ a)
+#define ck_isa(a)              Perl_ck_isa(aTHX_ a)
 #define ck_join(a)             Perl_ck_join(aTHX_ a)
 #define ck_length(a)           Perl_ck_length(aTHX_ a)
 #define ck_lfun(a)             Perl_ck_lfun(aTHX_ a)

diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index 4178179..f20345c 100644 (file)
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -6,7 +6,7 @@ use strict;
 
 our($VERSION, @ISA, @EXPORT_OK);
 
-$VERSION = "1.44";
+$VERSION = "1.45";
 
 use Carp;
 use Exporter ();
@@ -324,6 +324,7 @@ invert_opset function.
 
     lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp
     slt sgt sle sge seq sne scmp
+    isa
 
     substr vec stringify study pos length index rindex ord chr
 

diff --git a/feature.h b/feature.h
index 2b5b656..0044b06 100644 (file)
--- a/feature.h
+++ b/feature.h
@@ -17,14 +17,15 @@
 #define FEATURE_MYREF_BIT           0x0004
 #define FEATURE_EVALBYTES_BIT       0x0008
 #define FEATURE_FC_BIT              0x0010
-#define FEATURE_POSTDEREF_QQ_BIT    0x0020
-#define FEATURE_REFALIASING_BIT     0x0040
-#define FEATURE_SAY_BIT             0x0080
-#define FEATURE_SIGNATURES_BIT      0x0100
-#define FEATURE_STATE_BIT           0x0200
-#define FEATURE_SWITCH_BIT          0x0400
-#define FEATURE_UNIEVAL_BIT         0x0800
-#define FEATURE_UNICODE_BIT         0x1000
+#define FEATURE_ISA_BIT             0x0020
+#define FEATURE_POSTDEREF_QQ_BIT    0x0040
+#define FEATURE_REFALIASING_BIT     0x0080
+#define FEATURE_SAY_BIT             0x0100
+#define FEATURE_SIGNATURES_BIT      0x0200
+#define FEATURE_STATE_BIT           0x0400
+#define FEATURE_SWITCH_BIT          0x0800
+#define FEATURE_UNIEVAL_BIT         0x1000
+#define FEATURE_UNICODE_BIT         0x2000
 
 #define FEATURE_BUNDLE_DEFAULT 0
 #define FEATURE_BUNDLE_510     1
@@ -54,6 +55,12 @@
         FEATURE_IS_ENABLED_MASK(FEATURE_FC_BIT)) \
     )
 
+#define FEATURE_ISA_IS_ENABLED \
+    ( \
+       CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+        FEATURE_IS_ENABLED_MASK(FEATURE_ISA_BIT) \
+    )
+
 #define FEATURE_SAY_IS_ENABLED \
     ( \
        (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \
@@ -236,6 +243,14 @@ S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen,
             }
             return;
 
+        case 'i':
+            if (keylen == sizeof("feature_isa")-1
+                 && memcmp(subf+1, "sa", keylen - sizeof("feature_")) == 0) {
+                mask = FEATURE_ISA_BIT;
+                break;
+            }
+            return;
+
         case 'm':
             if (keylen == sizeof("feature_myref")-1
                  && memcmp(subf+1, "yref", keylen - sizeof("feature_")) == 0) {

diff --git a/gv.c b/gv.c
index 27cc0cf..eb4ab92 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -525,9 +525,10 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
     case KEY_END     : case KEY_eq     : case KEY_eval  :
     case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
-    case KEY_given   : case KEY_goto   : case KEY_grep  :
-    case KEY_gt   : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
-    case KEY_local: case KEY_lt: case KEY_m   : case KEY_map : case KEY_my:
+    case KEY_given   : case KEY_goto   : case KEY_grep  : case KEY_gt     :
+    case KEY_if      : case KEY_isa    : case KEY_INIT  : case KEY_last   :
+    case KEY_le      : case KEY_local  : case KEY_lt    : case KEY_m      :
+    case KEY_map     : case KEY_my:
     case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
     case KEY_package: case KEY_print: case KEY_printf:
     case KEY_q    : case KEY_qq   : case KEY_qr     : case KEY_qw    :

diff --git a/keywords.c b/keywords.c
index 9fa30e6..d503bc9 100644 (file)
--- a/keywords.c
+++ b/keywords.c
@@ -203,7 +203,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
           goto unknown;
       }
 
-    case 3: /* 28 tokens of length 3 */
+    case 3: /* 29 tokens of length 3 */
       switch (name[0])
       {
         case 'E':
@@ -320,13 +320,27 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
           goto unknown;
 
         case 'i':
-          if (name[1] == 'n' &&
-              name[2] == 't')
-          {                                       /* int              */
-            return -KEY_int;
-          }
+          switch (name[1])
+          {
+            case 'n':
+              if (name[2] == 't')
+              {                                   /* int              */
+                return -KEY_int;
+              }
 
-          goto unknown;
+              goto unknown;
+
+            case 's':
+              if (name[2] == 'a')
+              {                                   /* isa              */
+                return (all_keywords || FEATURE_ISA_IS_ENABLED ? -KEY_isa : 0);
+              }
+
+              goto unknown;
+
+            default:
+              goto unknown;
+          }
 
         case 'l':
           if (name[1] == 'o' &&
@@ -3437,5 +3451,5 @@ unknown:
 }
 
 /* Generated from:
- * db0472e0ad4f44bd0816cad799d63b60d1bbd7e11cef40ea15bf0d00f69669f6 regen/keywords.pl
+ * f77998a5bc995c1b42d3d080de227ef5f11638bcd329367431d8f193aef2d3cc regen/keywords.pl
  * ex: set ro: */

diff --git a/keywords.h b/keywords.h
index 2b1d598..23fa694 100644 (file)
--- a/keywords.h
+++ b/keywords.h
@@ -123,152 +123,153 @@
 #define KEY_index              107
 #define KEY_int                        108
 #define KEY_ioctl              109
-#define KEY_join               110
-#define KEY_keys               111
-#define KEY_kill               112
-#define KEY_last               113
-#define KEY_lc                 114
-#define KEY_lcfirst            115
-#define KEY_le                 116
-#define KEY_length             117
-#define KEY_link               118
-#define KEY_listen             119
-#define KEY_local              120
-#define KEY_localtime          121
-#define KEY_lock               122
-#define KEY_log                        123
-#define KEY_lstat              124
-#define KEY_lt                 125
-#define KEY_m                  126
-#define KEY_map                        127
-#define KEY_mkdir              128
-#define KEY_msgctl             129
-#define KEY_msgget             130
-#define KEY_msgrcv             131
-#define KEY_msgsnd             132
-#define KEY_my                 133
-#define KEY_ne                 134
-#define KEY_next               135
-#define KEY_no                 136
-#define KEY_not                        137
-#define KEY_oct                        138
-#define KEY_open               139
-#define KEY_opendir            140
-#define KEY_or                 141
-#define KEY_ord                        142
-#define KEY_our                        143
-#define KEY_pack               144
-#define KEY_package            145
-#define KEY_pipe               146
-#define KEY_pop                        147
-#define KEY_pos                        148
-#define KEY_print              149
-#define KEY_printf             150
-#define KEY_prototype          151
-#define KEY_push               152
-#define KEY_q                  153
-#define KEY_qq                 154
-#define KEY_qr                 155
-#define KEY_quotemeta          156
-#define KEY_qw                 157
-#define KEY_qx                 158
-#define KEY_rand               159
-#define KEY_read               160
-#define KEY_readdir            161
-#define KEY_readline           162
-#define KEY_readlink           163
-#define KEY_readpipe           164
-#define KEY_recv               165
-#define KEY_redo               166
-#define KEY_ref                        167
-#define KEY_rename             168
-#define KEY_require            169
-#define KEY_reset              170
-#define KEY_return             171
-#define KEY_reverse            172
-#define KEY_rewinddir          173
-#define KEY_rindex             174
-#define KEY_rmdir              175
-#define KEY_s                  176
-#define KEY_say                        177
-#define KEY_scalar             178
-#define KEY_seek               179
-#define KEY_seekdir            180
-#define KEY_select             181
-#define KEY_semctl             182
-#define KEY_semget             183
-#define KEY_semop              184
-#define KEY_send               185
-#define KEY_setgrent           186
-#define KEY_sethostent         187
-#define KEY_setnetent          188
-#define KEY_setpgrp            189
-#define KEY_setpriority                190
-#define KEY_setprotoent                191
-#define KEY_setpwent           192
-#define KEY_setservent         193
-#define KEY_setsockopt         194
-#define KEY_shift              195
-#define KEY_shmctl             196
-#define KEY_shmget             197
-#define KEY_shmread            198
-#define KEY_shmwrite           199
-#define KEY_shutdown           200
-#define KEY_sin                        201
-#define KEY_sleep              202
-#define KEY_socket             203
-#define KEY_socketpair         204
-#define KEY_sort               205
-#define KEY_splice             206
-#define KEY_split              207
-#define KEY_sprintf            208
-#define KEY_sqrt               209
-#define KEY_srand              210
-#define KEY_stat               211
-#define KEY_state              212
-#define KEY_study              213
-#define KEY_sub                        214
-#define KEY_substr             215
-#define KEY_symlink            216
-#define KEY_syscall            217
-#define KEY_sysopen            218
-#define KEY_sysread            219
-#define KEY_sysseek            220
-#define KEY_system             221
-#define KEY_syswrite           222
-#define KEY_tell               223
-#define KEY_telldir            224
-#define KEY_tie                        225
-#define KEY_tied               226
-#define KEY_time               227
-#define KEY_times              228
-#define KEY_tr                 229
-#define KEY_truncate           230
-#define KEY_uc                 231
-#define KEY_ucfirst            232
-#define KEY_umask              233
-#define KEY_undef              234
-#define KEY_unless             235
-#define KEY_unlink             236
-#define KEY_unpack             237
-#define KEY_unshift            238
-#define KEY_untie              239
-#define KEY_until              240
-#define KEY_use                        241
-#define KEY_utime              242
-#define KEY_values             243
-#define KEY_vec                        244
-#define KEY_wait               245
-#define KEY_waitpid            246
-#define KEY_wantarray          247
-#define KEY_warn               248
-#define KEY_when               249
-#define KEY_while              250
-#define KEY_write              251
-#define KEY_x                  252
-#define KEY_xor                        253
-#define KEY_y                  254
+#define KEY_isa                        110
+#define KEY_join               111
+#define KEY_keys               112
+#define KEY_kill               113
+#define KEY_last               114
+#define KEY_lc                 115
+#define KEY_lcfirst            116
+#define KEY_le                 117
+#define KEY_length             118
+#define KEY_link               119
+#define KEY_listen             120
+#define KEY_local              121
+#define KEY_localtime          122
+#define KEY_lock               123
+#define KEY_log                        124
+#define KEY_lstat              125
+#define KEY_lt                 126
+#define KEY_m                  127
+#define KEY_map                        128
+#define KEY_mkdir              129
+#define KEY_msgctl             130
+#define KEY_msgget             131
+#define KEY_msgrcv             132
+#define KEY_msgsnd             133
+#define KEY_my                 134
+#define KEY_ne                 135
+#define KEY_next               136
+#define KEY_no                 137
+#define KEY_not                        138
+#define KEY_oct                        139
+#define KEY_open               140
+#define KEY_opendir            141
+#define KEY_or                 142
+#define KEY_ord                        143
+#define KEY_our                        144
+#define KEY_pack               145
+#define KEY_package            146
+#define KEY_pipe               147
+#define KEY_pop                        148
+#define KEY_pos                        149
+#define KEY_print              150
+#define KEY_printf             151
+#define KEY_prototype          152
+#define KEY_push               153
+#define KEY_q                  154
+#define KEY_qq                 155
+#define KEY_qr                 156
+#define KEY_quotemeta          157
+#define KEY_qw                 158
+#define KEY_qx                 159
+#define KEY_rand               160
+#define KEY_read               161
+#define KEY_readdir            162
+#define KEY_readline           163
+#define KEY_readlink           164
+#define KEY_readpipe           165
+#define KEY_recv               166
+#define KEY_redo               167
+#define KEY_ref                        168
+#define KEY_rename             169
+#define KEY_require            170
+#define KEY_reset              171
+#define KEY_return             172
+#define KEY_reverse            173
+#define KEY_rewinddir          174
+#define KEY_rindex             175
+#define KEY_rmdir              176
+#define KEY_s                  177
+#define KEY_say                        178
+#define KEY_scalar             179
+#define KEY_seek               180
+#define KEY_seekdir            181
+#define KEY_select             182
+#define KEY_semctl             183
+#define KEY_semget             184
+#define KEY_semop              185
+#define KEY_send               186
+#define KEY_setgrent           187
+#define KEY_sethostent         188
+#define KEY_setnetent          189
+#define KEY_setpgrp            190
+#define KEY_setpriority                191
+#define KEY_setprotoent                192
+#define KEY_setpwent           193
+#define KEY_setservent         194
+#define KEY_setsockopt         195
+#define KEY_shift              196
+#define KEY_shmctl             197
+#define KEY_shmget             198
+#define KEY_shmread            199
+#define KEY_shmwrite           200
+#define KEY_shutdown           201
+#define KEY_sin                        202
+#define KEY_sleep              203
+#define KEY_socket             204
+#define KEY_socketpair         205
+#define KEY_sort               206
+#define KEY_splice             207
+#define KEY_split              208
+#define KEY_sprintf            209
+#define KEY_sqrt               210
+#define KEY_srand              211
+#define KEY_stat               212
+#define KEY_state              213
+#define KEY_study              214
+#define KEY_sub                        215
+#define KEY_substr             216
+#define KEY_symlink            217
+#define KEY_syscall            218
+#define KEY_sysopen            219
+#define KEY_sysread            220
+#define KEY_sysseek            221
+#define KEY_system             222
+#define KEY_syswrite           223
+#define KEY_tell               224
+#define KEY_telldir            225
+#define KEY_tie                        226
+#define KEY_tied               227
+#define KEY_time               228
+#define KEY_times              229
+#define KEY_tr                 230
+#define KEY_truncate           231
+#define KEY_uc                 232
+#define KEY_ucfirst            233
+#define KEY_umask              234
+#define KEY_undef              235
+#define KEY_unless             236
+#define KEY_unlink             237
+#define KEY_unpack             238
+#define KEY_unshift            239
+#define KEY_untie              240
+#define KEY_until              241
+#define KEY_use                        242
+#define KEY_utime              243
+#define KEY_values             244
+#define KEY_vec                        245
+#define KEY_wait               246
+#define KEY_waitpid            247
+#define KEY_wantarray          248
+#define KEY_warn               249
+#define KEY_when               250
+#define KEY_while              251
+#define KEY_write              252
+#define KEY_x                  253
+#define KEY_xor                        254
+#define KEY_y                  255
 
 /* Generated from:
- * db0472e0ad4f44bd0816cad799d63b60d1bbd7e11cef40ea15bf0d00f69669f6 regen/keywords.pl
+ * f77998a5bc995c1b42d3d080de227ef5f11638bcd329367431d8f193aef2d3cc regen/keywords.pl
  * ex: set ro: */

diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t
index 6ee935f..991412a 100644 (file)
--- a/lib/B/Deparse-core.t
+++ b/lib/B/Deparse-core.t
@@ -36,7 +36,7 @@ BEGIN {
 
 use strict;
 use Test::More;
-plan tests => 3886;
+plan tests => 3904;
 
 use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
                                     # logic to add CORE::
@@ -79,23 +79,25 @@ sub testit {
        my $desc = "$keyword: lex=$lex $expr => $expected_expr";
        $desc .= " (lex sub)" if $lexsub;
 
-
         my $code;
        my $code_ref;
        if ($lexsub) {
            package lexsubtest;
-           no warnings 'experimental::lexical_subs';
+           no warnings 'experimental::lexical_subs', 'experimental::isa';
            use feature 'lexical_subs';
            no strict 'vars';
             $code = "sub { state sub $keyword; ${vars}() = $expr }";
+           $code = "use feature 'isa';\n$code" if $keyword eq "isa";
            $code_ref = eval $code
                            or die "$@ in $expr";
        }
        else {
            package test;
+           no warnings 'experimental::isa';
            use subs ();
            import subs $keyword;
            $code = "no strict 'vars'; sub { ${vars}() = $expr }";
+           $code = "use feature 'isa';\n$code" if $keyword eq "isa";
            $code_ref = eval $code
                            or die "$@ in $expr";
        }
@@ -545,6 +547,7 @@ hex              01    $
 index            23    p
 int              01    $
 ioctl            3     p
+isa              B     -
 join             13    p
 # keys handled specially
 kill             123   p

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 1ae4619..ee126b1 100644 (file)
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -52,7 +52,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         MDEREF_SHIFT
     );
 
-$VERSION = '1.51';
+$VERSION = '1.52';
 use strict;
 our $AUTOLOAD;
 use warnings ();
@@ -3060,6 +3060,8 @@ sub pp_sge { binop(@_, "ge", 15) }
 sub pp_sle { binop(@_, "le", 15) }
 sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) }
 
+sub pp_isa { binop(@_, "isa", 15) }
+
 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
 

diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm
index 972f0bb..bcf8457 100644 (file)
--- a/lib/B/Op_private.pm
+++ b/lib/B/Op_private.pm
@@ -399,6 +399,7 @@ $bits{i_preinc}{0} = $bf[0];
 @{$bits{index}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 $bits{int}{0} = $bf[0];
 @{$bits{ioctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{isa}}{1,0} = ($bf[1], $bf[1]);
 @{$bits{join}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 $bits{keys}{0} = $bf[0];
 @{$bits{kill}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);

diff --git a/lib/feature.pm b/lib/feature.pm
index c81a35f..668b430 100644 (file)
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -9,6 +9,7 @@ our $VERSION = '1.57';
 
 our %feature = (
     fc              => 'feature_fc',
+    isa             => 'feature_isa',
     say             => 'feature_say',
     state           => 'feature_state',
     switch          => 'feature_switch',
@@ -29,7 +30,7 @@ our %feature_bundle = (
     "5.15"    => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)],
     "5.23"    => [qw(current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)],
     "5.27"    => [qw(bitwise current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)],
-    "all"     => [qw(bitwise current_sub declared_refs evalbytes fc postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)],
+    "all"     => [qw(bitwise current_sub declared_refs evalbytes fc isa postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)],
     "default" => [qw()],
 );
 
@@ -350,6 +351,14 @@ Reference to a Variable> for examples.
 
 This feature is available from Perl 5.26 onwards.
 
+=head2 The 'isa' feature
+
+This allows the use of the C<isa> infix operator, which tests whether the
+scalar given by the left operand is an object of the class given by the
+right operand. See L<perlop/Class Instance Operator> for more details.
+
+This feature is available from Perl 5.32 onwards.
+
 =head1 FEATURE BUNDLES
 
 It's possible to load multiple features together, using

diff --git a/lib/warnings.pm b/lib/warnings.pm
index ea06788..d434dcd 100644 (file)
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -5,7 +5,7 @@
 
 package warnings;
 
-our $VERSION = "1.45";
+our $VERSION = "1.46";
 
 # Verify that we're called correctly so that warnings will work.
 # Can't use Carp, since Carp uses us!
@@ -106,6 +106,9 @@ our %Offsets = (
     'experimental::private_use'                => 140,
     'experimental::uniprop_wildcards'  => 142,
     'experimental::vlb'                        => 144,
+
+    # Warnings Categories added in Perl 5.031
+    'experimental::isa'                        => 146,
 );
 
 our %Bits = (
@@ -119,11 +122,12 @@ our %Bits = (
     'digit'                            => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
     'exec'                             => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
     'exiting'                          => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
-    'experimental'                     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x51\x15\x50\x51\x01", # [51..56,58..62,66..68,70..72]
+    'experimental'                     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x51\x15\x50\x51\x05", # [51..56,58..62,66..68,70..73]
     'experimental::alpha_assertions'   => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [67]
     'experimental::bitwise'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [58]
     'experimental::const_attr'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [59]
     'experimental::declared_refs'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [66]
+    'experimental::isa'                        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [73]
     'experimental::lexical_subs'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [52]
     'experimental::postderef'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [55]
     'experimental::private_use'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [70]
@@ -195,11 +199,12 @@ our %DeadBits = (
     'digit'                            => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
     'exec'                             => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
     'exiting'                          => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
-    'experimental'                     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\xa2\x2a\xa0\xa2\x02", # [51..56,58..62,66..68,70..72]
+    'experimental'                     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\xa2\x2a\xa0\xa2\x0a", # [51..56,58..62,66..68,70..73]
     'experimental::alpha_assertions'   => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [67]
     'experimental::bitwise'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [58]
     'experimental::const_attr'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [59]
     'experimental::declared_refs'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [66]
+    'experimental::isa'                        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [73]
     'experimental::lexical_subs'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [52]
     'experimental::postderef'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [55]
     'experimental::private_use'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [70]
@@ -262,8 +267,8 @@ our %DeadBits = (
 
 # These are used by various things, including our own tests
 our $NONE                              =  "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
-our $DEFAULT                           =  "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51\x55\x50\x51\x01", # [2,4,22,23,25,52..56,58..63,66..68,70..72]
-our $LAST_BIT                          =  146 ;
+our $DEFAULT                           =  "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51\x55\x50\x51\x05", # [2,4,22,23,25,52..56,58..63,66..68,70..73]
+our $LAST_BIT                          =  148 ;
 our $BYTES                             =  19 ;
 
 sub Croaker
@@ -813,6 +818,8 @@ The current hierarchy is:
          |                 |
          |                 +- experimental::declared_refs
          |                 |
+         |                 +- experimental::isa
+         |                 |
          |                 +- experimental::lexical_subs
          |                 |
          |                 +- experimental::postderef

diff --git a/op.c b/op.c
index 66d773f..fcd29dd 100644 (file)
--- a/op.c
+++ b/op.c
@@ -15090,6 +15090,22 @@ Perl_ck_length(pTHX_ OP *o)
 }
 
 
+OP *
+Perl_ck_isa(pTHX_ OP *o)
+{
+    OP *classop = cBINOPo->op_last;
+
+    PERL_ARGS_ASSERT_CK_ISA;
+
+    /* Convert barename into PV */
+    if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
+        /* TODO: Optionally convert package to raw HV here */
+        classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
+    }
+
+    return o;
+}
+
 
 /*
    ---------------------------------------------------------

diff --git a/opcode.h b/opcode.h
index 021ea6b..c4104dd 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -543,6 +543,7 @@ EXTCONST char* const PL_op_name[] = {
        "lvrefslice",
        "lvavref",
        "anonconst",
+       "isa",
        "freed",
 };
 #endif
@@ -948,6 +949,7 @@ EXTCONST char* const PL_op_desc[] = {
        "lvalue ref assignment",
        "lvalue array reference",
        "anonymous constant",
+       "derived class test",
        "freed op",
 };
 #endif
@@ -1365,6 +1367,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
        Perl_pp_lvrefslice,
        Perl_pp_lvavref,
        Perl_pp_anonconst,
+       Perl_pp_isa,
 }
 #endif
 #ifdef PERL_PPADDR_INITED
@@ -1778,6 +1781,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
        Perl_ck_null,           /* lvrefslice */
        Perl_ck_null,           /* lvavref */
        Perl_ck_null,           /* anonconst */
+       Perl_ck_isa,            /* isa */
 }
 #endif
 #ifdef PERL_CHECK_INITED
@@ -2187,6 +2191,7 @@ EXTCONST U32 PL_opargs[] = {
        0x00000440,     /* lvrefslice */
        0x00000b40,     /* lvavref */
        0x00000144,     /* anonconst */
+       0x00000204,     /* isa */
 };
 #endif
 
@@ -2855,6 +2860,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
      233, /* lvrefslice */
      234, /* lvavref */
        0, /* anonconst */
+      12, /* isa */
 
 };
 
@@ -2879,7 +2885,7 @@ EXTCONST U16  PL_op_private_bitdefs[] = {
     0x0438, 0x1a50, 0x426c, 0x3d28, 0x3505, /* const */
     0x2fdc, 0x3659, /* gvsv */
     0x18b5, /* gv */
-    0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, smartmatch, lslice, xor */
+    0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, smartmatch, lslice, xor, isa */
     0x2fdc, 0x41b8, 0x03d7, /* padsv */
     0x2fdc, 0x41b8, 0x05b4, 0x30cc, 0x3ea9, /* padav */
     0x2fdc, 0x41b8, 0x05b4, 0x0650, 0x30cc, 0x3ea8, 0x2b41, /* padhv */
@@ -3348,6 +3354,7 @@ EXTCONST U8 PL_op_private_valid[] = {
     /* LVREFSLICE */ (OPpLVAL_INTRO),
     /* LVAVREF    */ (OPpARG1_MASK|OPpPAD_STATE|OPpLVAL_INTRO),
     /* ANONCONST  */ (OPpARG1_MASK),
+    /* ISA        */ (OPpARG2_MASK),
 
 };
 

diff --git a/opnames.h b/opnames.h
index d87ba88..d63371a 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -411,10 +411,11 @@ typedef enum opcode {
        OP_LVREFSLICE    = 394,
        OP_LVAVREF       = 395,
        OP_ANONCONST     = 396,
+       OP_ISA           = 397,
        OP_max          
 } opcode;
 
-#define MAXO 397
+#define MAXO 398
 #define OP_FREED MAXO
 
 /* the OP_IS_* macros are optimized to a simple range check because

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 23d3fe7..6648812 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -25,6 +25,15 @@ XXX New core language features go here.  Summarize user-visible core language
 enhancements.  Particularly prominent performance optimisations could go
 here, but most should go in the L</Performance Enhancements> section.
 
+=head2 The isa Operator
+
+A new experimental infix operator called C<isa> tests whether a given object
+is an instance of a given class or a class derived from it:
+
+    if( $obj isa Package::Name ) { ... }
+
+For more detail see L<perlop/Class Instance Operator>.
+
 [ List each enhancement as a =head2 entry ]
 
 =head1 Security

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 465317b..5930326 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3262,6 +3262,12 @@ an anonymous subroutine, or a reference to a subroutine.
 (W overload) You tried to overload a constant type the overload package is
 unaware of.
 
+=item isa is experimental
+
+(S experimental::isa) This warning is emitted if you use the (C<isa>)
+operator. This operator is currently experimental and its behaviour may
+change in future releases of Perl.
+
 =item -i used with no filenames on the command line, reading from STDIN
 
 (S inplace) The C<-i> option was passed on the command line, indicating

diff --git a/pod/perlop.pod b/pod/perlop.pod
index c4eecd6..57bda73 100644 (file)
--- a/pod/perlop.pod
+++ b/pod/perlop.pod
@@ -78,6 +78,7 @@ values only, not array values.
     nonassoc   named unary operators
     nonassoc   < > <= >= lt gt le ge
     nonassoc   == != <=> eq ne cmp ~~
+    nonassoc    isa
     left       &
     left       | ^
     left       &&
@@ -575,6 +576,25 @@ function, available in Perl v5.16 or later:
 
     if ( fc($x) eq fc($y) ) { ... }
 
+=head2 Class Instance Operator
+X<isa operator>
+
+Binary C<isa> evaluates to true when left argument is an object instance of
+the class (or a subclass derived from that class) given by the right argument.
+If the left argument is not defined, not a blessed object instance, or does
+not derive from the class given by the right argument, the operator evaluates
+as false. The right argument may give the class either as a barename or a
+scalar expression that yields a string class name:
+
+    if( $obj isa Some::Class ) { ... }
+
+    if( $obj isa "Different::Class" ) { ... }
+    if( $obj isa $name_of_class ) { ... }
+
+This is an experimental feature and is available from Perl 5.31.6 when enabled
+by C<use feature 'isa'>. It emits a warning in the C<experimental::isa>
+category.
+
 =head2 Smartmatch Operator
 
 First available in Perl 5.10.1 (the 5.10.0 version behaved differently),

diff --git a/pp.c b/pp.c
index 9a06fcc..5cd32e1 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -7143,6 +7143,18 @@ PP(pp_argcheck)
     return NORMAL;
 }
 
+PP(pp_isa)
+{
+    dSP;
+    SV *left, *right;
+
+    right = POPs;
+    left  = TOPs;
+
+    SETs(boolSV(sv_isa_sv(left, right)));
+    RETURN;
+}
+
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */

diff --git a/pp_proto.h b/pp_proto.h
index 407cbd1..580ce93 100644 (file)
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -126,6 +126,7 @@ PERL_CALLCONV OP *Perl_pp_index(pTHX);
 PERL_CALLCONV OP *Perl_pp_int(pTHX);
 PERL_CALLCONV OP *Perl_pp_introcv(pTHX);
 PERL_CALLCONV OP *Perl_pp_ioctl(pTHX);
+PERL_CALLCONV OP *Perl_pp_isa(pTHX);
 PERL_CALLCONV OP *Perl_pp_iter(pTHX);
 PERL_CALLCONV OP *Perl_pp_join(pTHX);
 PERL_CALLCONV OP *Perl_pp_kvaslice(pTHX);

diff --git a/proto.h b/proto.h
index 649b6d3..364b12e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -480,6 +480,11 @@ PERL_CALLCONV OP * Perl_ck_index(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_CK_INDEX      \
        assert(o)
 
+PERL_CALLCONV OP *     Perl_ck_isa(pTHX_ OP *o)
+                       __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_CK_ISA        \
+       assert(o)
+
 PERL_CALLCONV OP *     Perl_ck_join(pTHX_ OP *o)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_CK_JOIN       \
@@ -3412,6 +3417,11 @@ PERL_CALLCONV void       Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN off
 PERL_CALLCONV int      Perl_sv_isa(pTHX_ SV* sv, const char *const name);
 #define PERL_ARGS_ASSERT_SV_ISA        \
        assert(name)
+PERL_CALLCONV bool     Perl_sv_isa_sv(pTHX_ SV* sv, SV* namesv)
+                       __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_SV_ISA_SV     \
+       assert(sv); assert(namesv)
+
 PERL_CALLCONV int      Perl_sv_isobject(pTHX_ SV* sv);
 #define PERL_ARGS_ASSERT_SV_ISOBJECT
 #ifndef NO_MATHOMS

diff --git a/regen/feature.pl b/regen/feature.pl
index efecebb..e3eb8e9 100755 (executable)
--- a/regen/feature.pl
+++ b/regen/feature.pl
@@ -35,6 +35,7 @@ my %feature = (
     unicode_strings => 'unicode',
     fc              => 'fc',
     signatures      => 'signatures',
+    isa             => 'isa',
 );
 
 # NOTE: If a feature is ever enabled in a non-contiguous range of Perl
@@ -752,6 +753,14 @@ Reference to a Variable> for examples.
 
 This feature is available from Perl 5.26 onwards.
 
+=head2 The 'isa' feature
+
+This allows the use of the C<isa> infix operator, which tests whether the
+scalar given by the left operand is an object of the class given by the
+right operand. See L<perlop/Class Instance Operator> for more details.
+
+This feature is available from Perl 5.32 onwards.
+
 =head1 FEATURE BUNDLES
 
 It's possible to load multiple features together, using

diff --git a/regen/keywords.pl b/regen/keywords.pl
index 9619d86..ffc4882 100755 (executable)
--- a/regen/keywords.pl
+++ b/regen/keywords.pl
@@ -46,6 +46,7 @@ my %feature_kw = (
     evalbytes => 'evalbytes',
     __SUB__   => '__SUB__',
     fc        => 'fc',
+    isa       => 'isa',
 );
 
 my %pos = map { ($_ => 1) } @{$by_strength{'+'}};
@@ -217,6 +218,7 @@ __END__
 -index
 -int
 -ioctl
+-isa
 -join
 -keys
 -kill

diff --git a/regen/opcodes b/regen/opcodes
index 4e82369..745acbb 100644 (file)
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -572,3 +572,5 @@ lvref               lvalue ref assignment   ck_null         d%
 lvrefslice     lvalue ref assignment   ck_null         d@
 lvavref                lvalue array reference  ck_null         d%
 anonconst      anonymous constant      ck_null         ds1
+
+isa            derived class test      ck_isa          s2

diff --git a/regen/warnings.pl b/regen/warnings.pl
index 1c58b3a..93e6763 100644 (file)
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -16,7 +16,7 @@
 #
 # This script is normally invoked from regen.pl.
 
-$VERSION = '1.45';
+$VERSION = '1.46';
 
 BEGIN {
     require './regen/regen_lib.pl';
@@ -117,6 +117,8 @@ my $tree = {
                                     [ 5.029, DEFAULT_ON ],
                                 'experimental::vlb' =>
                                     [ 5.029, DEFAULT_ON ],
+                                'experimental::isa' =>
+                                    [ 5.031, DEFAULT_ON ],
                         }],
 
         'missing'       => [ 5.021, DEFAULT_OFF],

diff --git a/sv.c b/sv.c
index 0a853bc..6a23ae5 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -10301,8 +10301,12 @@ Perl_sv_isobject(pTHX_ SV *sv)
 =for apidoc sv_isa
 
 Returns a boolean indicating whether the SV is blessed into the specified
-class.  This does not check for subtypes; use C<sv_derived_from> to verify
-an inheritance relationship.
+class.
+
+This does not check for subtypes or method overloading. Use C<sv_isa_sv> to
+verify an inheritance relationship in the same way as the C<isa> operator by
+respecting any C<isa()> method overloading; or C<sv_derived_from_sv> to test
+directly on the actual object type.
 
 =cut
 */

diff --git a/t/op/coreamp.t b/t/op/coreamp.t
index d7700e0..3320ff7 100644 (file)
--- a/t/op/coreamp.t
+++ b/t/op/coreamp.t
@@ -1162,9 +1162,9 @@ like $@, qr'^Undefined format "STDOUT" called',
     AUTOLOAD BEGIN CHECK CORE DESTROY END INIT UNITCHECK
     __DATA__ __END__
     and cmp default do dump else elsif eq eval for foreach format ge given goto
-    grep gt if last le local lt m map my ne next no or our package print printf
-    q qq qr qw qx redo require return s say sort state sub tr unless until use
-    when while x xor y
+    grep gt if isa last le local lt m map my ne next no or our package print
+    printf q qq qr qw qx redo require return s say sort state sub tr unless
+    until use when while x xor y
   );
   open my $kh, $keywords_file
     or die "$0 cannot open $keywords_file: $!";

diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 2ee63ef..1fa11c0 100644 (file)
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -17,7 +17,7 @@ use B;
 my %unsupported = map +($_=>1), qw (
  __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and
   cmp default do dump else elsif eq eval for foreach
-  format ge given goto grep gt if last le local lt m map my ne next
+  format ge given goto grep gt if isa last le local lt m map my ne next
   no  or  our  package  print  printf  q  qq  qr  qw  qx  redo  require
   return s say sort state sub tr unless until use
   when while x xor y

diff --git a/t/op/isa.t b/t/op/isa.t
new file mode 100644 (file)
index 0000000..96a9c21
--- /dev/null
+++ b/t/op/isa.t
@@ -0,0 +1,49 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+    set_up_inc('../lib');
+    require Config;
+}
+
+use strict;
+use feature 'isa';
+no warnings 'experimental::isa';
+
+plan 11;
+
+package BaseClass {}
+package DerivedClass { our @ISA = qw(BaseClass) }
+package CustomClass {
+   sub isa { length($_[1]) == 9; }
+}
+
+my $baseobj = bless {}, "BaseClass";
+my $derivedobj = bless {}, "DerivedClass";
+my $customobj = bless {}, "CustomClass";
+
+# Bareword package name
+ok($baseobj isa BaseClass, '$baseobj isa BaseClass');
+ok(not($baseobj isa Another::Class), '$baseobj is not Another::Class');
+
+# String package name
+ok($baseobj isa "BaseClass",         '$baseobj isa BaseClass');
+ok(not($baseobj isa "DerivedClass"), '$baseobj is not DerivedClass');
+
+ok($derivedobj isa "DerivedClass", '$derivedobj isa DerivedClass');
+ok($derivedobj isa "BaseClass",    '$derivedobj isa BaseClass');
+
+# Expression giving a package name
+my $classname = "DerivedClass";
+ok($derivedobj isa $classname, '$derivedobj isa DerivedClass via SV');
+
+# Invoked on instance which overrides ->isa
+ok($customobj isa "Something",          '$customobj isa Something');
+ok(not($customobj isa "SomethingElse"), '$customobj isa SomethingElse');
+
+ok(not(undef isa "BaseClass"), 'undef is not BaseClass');
+ok(not([] isa "BaseClass"),    'ARRAYref is not BaseClass');
+
+# TODO: Consider 
+#    LHS = other class

diff --git a/toke.c b/toke.c
index 6dcb6fe..ab358a1 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -7800,6 +7800,11 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct
     case KEY_ioctl:
         LOP(OP_IOCTL,XTERM);
 
+    case KEY_isa:
+        Perl_ck_warner_d(aTHX_
+            packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental");
+        Rop(OP_ISA);
+
     case KEY_join:
         LOP(OP_JOIN,XTERM);
 

diff --git a/universal.c b/universal.c
index 3658b9b..a2d7d86 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -188,6 +188,74 @@ Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len,
 }
 
 /*
+=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.
+
+This is the function used to implement the behaviour of the C<isa> operator.
+
+Not to be confused with the older C<sv_isa> function, which does not use an
+overloaded C<isa()> method, nor will check subclassing.
+
+=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;
+
+    /* This abuse of gv_fetchmeth_pv() with level = 1 skips the UNIVERSAL
+     * lookup
+     * TODO: Consider if we want a NOUNIVERSAL flag for requesting this in a
+     * more obvious way
+     */
+    isagv = gv_fetchmeth_pvn(SvSTASH(SvRV(sv)), "isa", 3, 1, 0);
+    if(isagv) {
+        dSP;
+        CV *isacv = isGV(isagv) ? GvCV(isagv) : (CV *)isagv;
+        SV *retsv;
+        bool ret;
+
+        PUTBACK;
+
+        ENTER;
+        SAVETMPS;
+
+        EXTEND(SP, 2);
+        PUSHMARK(SP);
+        PUSHs(sv);
+        PUSHs(namesv);
+        PUTBACK;
+
+        call_sv((SV *)isacv, G_SCALAR);
+
+        SPAGAIN;
+        retsv = POPs;
+        ret = SvTRUE(retsv);
+        PUTBACK;
+
+        FREETMPS;
+        LEAVE;
+
+        return ret;
+    }
+
+    /* TODO: Support namesv being an HV ref to the stash directly? */
+
+    return sv_derived_from_sv(sv, namesv, 0);
+}
+
+/*
 =for apidoc sv_does_sv
 
 Returns a boolean indicating whether the SV performs a specific, named role.

diff --git a/warnings.h b/warnings.h
index 0677df1..cf3d363 100644 (file)
--- a/warnings.h
+++ b/warnings.h
@@ -127,6 +127,10 @@
 #define WARN_EXPERIMENTAL__UNIPROP_WILDCARDS 71
 #define WARN_EXPERIMENTAL__VLB          72
 
+/* Warnings Categories added in Perl 5.031 */
+
+#define WARN_EXPERIMENTAL__ISA          73
+
 
 /*
 =for apidoc Amnh||WARN_ALL
@@ -202,6 +206,7 @@
 =for apidoc Amnh||WARN_EXPERIMENTAL__PRIVATE_USE
 =for apidoc Amnh||WARN_EXPERIMENTAL__UNIPROP_WILDCARDS
 =for apidoc Amnh||WARN_EXPERIMENTAL__VLB
+=for apidoc Amnh||WARN_EXPERIMENTAL__ISA
 
 =cut
 */