diff options
| -rw-r--r-- | MANIFEST | 3 | ||||
| -rwxr-xr-x | Makefile.SH | 4 | ||||
| -rwxr-xr-x | Porting/Maintainers.pl | 1 | ||||
| -rw-r--r-- | builtin.c | 103 | ||||
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | lib/builtin.pm | 102 | ||||
| -rw-r--r-- | lib/builtin.t | 78 | ||||
| -rw-r--r-- | pad.c | 23 | ||||
| -rw-r--r-- | perl.c | 1 | ||||
| -rw-r--r-- | pod/perldiag.pod | 5 | ||||
| -rw-r--r-- | proto.h | 2 | ||||
| -rw-r--r-- | vms/descrip_mms.template | 6 | ||||
| -rw-r--r-- | win32/GNUmakefile | 1 | ||||
| -rw-r--r-- | win32/Makefile | 1 |
15 files changed, 322 insertions, 10 deletions
@@ -14,6 +14,7 @@ AUTHORS Contact info for contributors autodoc.pl Creates pod/perlintern.pod and pod/perlapi.pod av.c Array value code av.h Array value header +builtin.c Functions in the builtin:: namespace caretx.c C file to create $^X cflags.SH A script that emits C compilation flags per file Changes Describe how to peruse changes between releases @@ -4806,6 +4807,8 @@ lib/Benchmark.pm Measure execution time lib/Benchmark.t See if Benchmark works lib/blib.pm For "use blib" lib/blib.t blib.pm test +lib/builtin.pm builtin function namespace +lib/builtin.t test builtin function namespace lib/bytes.pm Pragma to enable byte operations lib/bytes.t bytes.pm test lib/bytes_heavy.pl Support routines for byte pragma diff --git a/Makefile.SH b/Makefile.SH index 413fac5082..b2c7121dbd 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -532,7 +532,7 @@ h = $(h1) $(h2) $(h3) $(h4) $(h5) $(h6) c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro_core.c perl.c c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c -c3 = taint.c toke.c util.c deb.c run.c universal.c pad.c globals.c keywords.c +c3 = taint.c toke.c util.c deb.c run.c builtin.c universal.c pad.c globals.c keywords.c c4 = perlio.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c caretx.c dquote.c time64.c c5 = $(mallocsrc) @@ -548,7 +548,7 @@ $spitshell >>$Makefile <<'!NO!SUBS!' c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c $(mini_only_src) -obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro_core$(OBJ_EXT) keywords$(OBJ_EXT) +obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro_core$(OBJ_EXT) keywords$(OBJ_EXT) builtin$(OBJ_EXT) obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT) obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT) caretx$(OBJ_EXT) dquote$(OBJ_EXT) time64$(OBJ_EXT) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index b972700ce4..27af38c15d 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1439,6 +1439,7 @@ use File::Glob qw(:case); lib/User/pwent.{pm,t} lib/_charnames.pm lib/blib.{pm,t} + lib/builtin.{pm,t} lib/bytes.{pm,t} lib/bytes_heavy.pl lib/charnames.{pm,t} diff --git a/builtin.c b/builtin.c new file mode 100644 index 0000000000..7c68b0bf76 --- /dev/null +++ b/builtin.c @@ -0,0 +1,103 @@ +/* builtin.c + * + * Copyright (C) 2021 by Paul Evans and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* This file contains the code that implements functions in perl's "builtin::" + * namespace + */ + +#include "EXTERN.h" +#include "perl.h" + +#include "XSUB.h" + +XS(XS_builtin_true); +XS(XS_builtin_true) +{ + dXSARGS; + if(items) + croak_xs_usage(cv, ""); + XSRETURN_YES; +} + +XS(XS_builtin_false); +XS(XS_builtin_false) +{ + dXSARGS; + if(items) + croak_xs_usage(cv, ""); + XSRETURN_NO; +} + +XS(XS_builtin_isbool); +XS(XS_builtin_isbool) +{ + dXSARGS; + if(items != 1) + croak_xs_usage(cv, "sv"); + + SV *sv = ST(0); + if(SvIsBOOL(sv)) + XSRETURN_YES; + else + XSRETURN_NO; +} + +XS(XS_builtin_import); +XS(XS_builtin_import) +{ + dXSARGS; + + if(!PL_compcv) + Perl_croak(aTHX_ + "builtin::import can only be called at compiletime"); + + /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */ + ENTER; + SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); + SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1]; + SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); + + for(int i = 1; i < items; i++) { + SV *sym = ST(i); + if(strEQ(SvPV_nolen(sym), "import")) goto unavailable; + + SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym))); + SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym))); + + CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0); + if(!cv) goto unavailable; + + PADOFFSET off = pad_add_name_sv(ampname, padadd_STATE, 0, 0); + SvREFCNT_dec(PL_curpad[off]); + PL_curpad[off] = SvREFCNT_inc(cv); + continue; + +unavailable: + Perl_croak(aTHX_ + "'%" SVf "' is not recognised as a builtin function", sym); + } + + intro_my(); + + LEAVE; +} + +void +Perl_boot_core_builtin(pTHX) +{ + newXS_flags("builtin::true", &XS_builtin_true, __FILE__, NULL, 0); + newXS_flags("builtin::false", &XS_builtin_false, __FILE__, NULL, 0); + newXS_flags("builtin::isbool", &XS_builtin_isbool, __FILE__, NULL, 0); + + newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0); +} + +/* + * ex: set ts=8 sts=4 sw=4 et: + */ @@ -666,6 +666,7 @@ ApR |U8 |block_gimme : Used in perly.y ApdR |int |block_start |int full Aodxp |void |blockhook_register |NN BHK *hk +p |void |boot_core_builtin : Used in perl.c p |void |boot_core_UNIVERSAL : Used in perl.c @@ -1241,6 +1241,7 @@ #define bind_match(a,b,c) Perl_bind_match(aTHX_ a,b,c) #define boot_core_PerlIO() Perl_boot_core_PerlIO(aTHX) #define boot_core_UNIVERSAL() Perl_boot_core_UNIVERSAL(aTHX) +#define boot_core_builtin() Perl_boot_core_builtin(aTHX) #define boot_core_mro() Perl_boot_core_mro(aTHX) #define cando(a,b,c) Perl_cando(aTHX_ a,b,c) #define check_utf8_print(a,b) Perl_check_utf8_print(aTHX_ a,b) diff --git a/lib/builtin.pm b/lib/builtin.pm new file mode 100644 index 0000000000..461f7ca5fe --- /dev/null +++ b/lib/builtin.pm @@ -0,0 +1,102 @@ +package builtin 0.001; + +use strict; +use warnings; + +# All code, including &import, is implemented by always-present functions in +# the perl interpreter itself. +# See also `builtin.c` in perl source + +1; +__END__ + +=head1 NAME + +builtin - Perl pragma to import built-in utility functions + +=head1 SYNOPSIS + + use builtin qw( true false isbool ); + +=head1 DESCRIPTION + +Perl provides several utility functions in the C<builtin> package. These are +plain functions, and look and behave just like regular user-defined functions +do. They do not provide new syntax or require special parsing. These functions +are always present in the interpreter and can be called at any time by their +fully-qualified names. By default they are not available as short names, but +can be requested for convenience. + +Individual named functions can be imported by listing them as import +parameters on the C<use> statement for this pragma. + +=head2 Lexical Import + +This pragma module creates I<lexical> aliases in the currently-compiling scope +to these builtin functions. This is similar to the lexical effect of other +pragmas such as L<strict> and L<feature>. + + sub classify + { + my $sv = shift; + + use builtin 'isbool'; + return isbool($sv) ? "boolean" : "not a boolean"; + } + + # the isbool() function is no longer visible here + # but may still be called by builtin::isbool() + +Because these functions are imported lexically, rather than by package +symbols, the user does not need to take any special measures to ensure they +don't accidentally appear as object methods from a class. + + package An::Object::Class { + use builtin 'true', 'false'; + ... + } + + # does not appear as a method + An::Object::Class->true; + + # Can't locate object method "true" via package "An::Object::Class" + # at ... + +=head1 FUNCTIONS + +=head2 true + + $val = true; + +Returns the boolean truth value. While any scalar value can be tested for +truth and most defined, non-empty and non-zero values are considered "true" +by perl, this one is special in that L</isbool> considers it to be a +distinguished boolean value. + +This gives an equivalent value to expressions like C<!!1> or C<!0>. + +=head2 false + + $val = false; + +Returns the boolean fiction value. While any non-true scalar value is +considered "false" by perl, this one is special in that L</isbool> considers +it to be a distinguished boolean value. + +This gives an equivalent value to expressions like C<!!0> or C<!1>. + +=head2 isbool + + $bool = isbool($val); + +Returns true when given a distinguished boolean value, or false if not. A +distinguished boolean value is the result of any boolean-returning builtin +function (such as C<true> or C<isbool> itself), boolean-returning operator +(such as the C<eq> or C<==> comparison tests or the C<!> negation operator), +or any variable containing one of these results. + +=head1 SEE ALSO + +L<perlop>, L<perlfunc>, L<Scalar::Util> + +=cut diff --git a/lib/builtin.t b/lib/builtin.t new file mode 100644 index 0000000000..003efd5ff2 --- /dev/null +++ b/lib/builtin.t @@ -0,0 +1,78 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + require './test.pl'; + set_up_inc('../lib'); +} + +use strict; +use warnings; + +# booleans +{ + use builtin qw( true false isbool ); + + ok(true, 'true is true'); + ok(!false, 'false is false'); + + ok(isbool(true), 'true is bool'); + ok(isbool(false), 'false is bool'); + ok(!isbool(undef), 'undef is not bool'); + ok(!isbool(1), '1 is not bool'); + ok(!isbool(""), 'empty is not bool'); + + my $truevar = (5 == 5); + my $falsevar = (5 == 6); + + ok(isbool($truevar), '$truevar is bool'); + ok(isbool($falsevar), '$falsevar is bool'); + + ok(isbool(isbool(true)), 'isbool true is bool'); + ok(isbool(isbool(123)), 'isbool false is bool'); +} + +# imports are lexical; should not be visible here +{ + my $ok = eval 'true()'; my $e = $@; + ok(!$ok, 'true() not visible outside of lexical scope'); + like($e, qr/^Undefined subroutine &main::true called at /, 'failure from true() not visible'); +} + +# lexical imports work fine in a variety of situations +{ + sub regularfunc { + use builtin 'true'; + return true; + } + ok(regularfunc(), 'true in regular sub'); + + my sub lexicalfunc { + use builtin 'true'; + return true; + } + ok(lexicalfunc(), 'true in lexical sub'); + + my $coderef = sub { + use builtin 'true'; + return true; + }; + ok($coderef->(), 'true in anon sub'); + + sub recursefunc { + use builtin 'true'; + return recursefunc() if @_; + return true; + } + ok(recursefunc("rec"), 'true in self-recursive sub'); + + my $recursecoderef = sub { + use feature 'current_sub'; + use builtin 'true'; + return __SUB__->() if @_; + return true; + }; + ok($recursecoderef->("rec"), 'true in self-recursive anon sub'); +} + +done_testing(); @@ -2208,11 +2208,22 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto))); else CvGV_set(cv,CvGV(proto)); CvSTASH_set(cv, CvSTASH(proto)); - OP_REFCNT_LOCK; - CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); - OP_REFCNT_UNLOCK; - CvSTART(cv) = CvSTART(proto); - CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); + + /* It is unlikely that proto is an xsub, but it could happen; e.g. if a + * module has performed a lexical sub import trick on an xsub. This + * happens with builtin::import, for example + */ + if (UNLIKELY(CvISXSUB(proto))) { + CvXSUB(cv) = CvXSUB(proto); + CvXSUBANY(cv) = CvXSUBANY(proto); + } + else { + OP_REFCNT_LOCK; + CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); + OP_REFCNT_UNLOCK; + CvSTART(cv) = CvSTART(proto); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); + } if (SvPOK(proto)) { sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); @@ -2222,7 +2233,7 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) if (SvMAGIC(proto)) mg_copy((SV *)proto, (SV *)cv, 0, 0); - if (CvPADLIST(proto)) + if (!CvISXSUB(proto) && CvPADLIST(proto)) cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv); DEBUG_Xv( @@ -2437,6 +2437,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) boot_core_PerlIO(); boot_core_UNIVERSAL(); + boot_core_builtin(); boot_core_mro(); newXS("Internals::V", S_Internals_V, __FILE__); diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 0f11e0ea8e..29fea0d604 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3293,6 +3293,11 @@ 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 '%s' is not recognised as a builtin function + +(F) An attempt was made to C<use> the L<builtin> pragma module to create +a lexical alias for an unknown function name. + =item isa is experimental (S experimental::isa) This warning is emitted if you use the (C<isa>) @@ -359,6 +359,8 @@ PERL_CALLCONV void Perl_boot_core_PerlIO(pTHX); #define PERL_ARGS_ASSERT_BOOT_CORE_PERLIO PERL_CALLCONV void Perl_boot_core_UNIVERSAL(pTHX); #define PERL_ARGS_ASSERT_BOOT_CORE_UNIVERSAL +PERL_CALLCONV void Perl_boot_core_builtin(pTHX); +#define PERL_ARGS_ASSERT_BOOT_CORE_BUILTIN PERL_CALLCONV void Perl_boot_core_mro(pTHX); #define PERL_ARGS_ASSERT_BOOT_CORE_MRO PERL_CALLCONV int Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen); diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index ca1277b6d2..063f797e8a 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -226,14 +226,14 @@ FULLLIBS2 = $(LIBS2)|$(THRLIBS1)|$(THRLIBS2) #### End of system configuration section. #### -c0 = $(MALLOC_C) av.c caretx.c deb.c doio.c doop.c dquote.c dump.c globals.c gv.c hv.c mro_core.c +c0 = $(MALLOC_C) av.c builtin.c caretx.c deb.c doio.c doop.c dquote.c dump.c globals.c gv.c hv.c mro_core.c c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlio.c c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sort.c pp_sys.c regcomp.c regexec.c reentr.c c3 = run.c scope.c sv.c taint.c time64.c toke.c universal.c utf8.c util.c vms.c keywords.c c = $(c0) $(c1) $(c2) $(c3) obj0 = perl$(O) -obj1 = $(MALLOC_O) av$(O) caretx$(O) deb$(O) doio$(O) doop$(O) dquote$(O) dump$(O) mro_core$(O) globals$(O) gv$(O) hv$(O) +obj1 = $(MALLOC_O) av$(O) builtin$(0) caretx$(O) deb$(O) doio$(O) doop$(O) dquote$(O) dump$(O) mro_core$(O) globals$(O) gv$(O) hv$(O) obj2 = keywords$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O) perlio$(O) obj3 = perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O) pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) obj4 = regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) time64$(O) toke$(O) universal$(O) utf8$(O) util$(O) vms$(O) @@ -623,6 +623,8 @@ $(ARCHAUTO)time.stamp : # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE av$(O) : av.c $(h) $(CC) $(CORECFLAGS) $(MMS$SOURCE) +builtin$(O) : builtin.c $(h) + $(CC) $(CORECFLAGS) $(MMS$SOURCE) caretx$(O) : caretx.c $(h) $(CC) $(CORECFLAGS) $(MMS$SOURCE) deb$(O) : deb.c $(h) diff --git a/win32/GNUmakefile b/win32/GNUmakefile index c2406588c4..6ba435e4b2 100644 --- a/win32/GNUmakefile +++ b/win32/GNUmakefile @@ -945,6 +945,7 @@ MICROCORE_SRC = \ ..\dump.c \ ..\hv.c \ ..\av.c \ + ..\builtin.c \ ..\caretx.c \ ..\deb.c \ ..\doio.c \ diff --git a/win32/Makefile b/win32/Makefile index 64e6bc3917..26376b9e46 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -664,6 +664,7 @@ DEL = del MICROCORE_SRC = \ ..\av.c \ ..\caretx.c \ + ..\builtin.c \ ..\deb.c \ ..\doio.c \ ..\doop.c \ |