Skip to content

Commit

Permalink
Fix assorted bugs related to not having a UNIVERSAL::import
Browse files Browse the repository at this point in the history
Since perl 5.0 the methods "import" and "unimport" have been
special cased in gv.c (unimport was removed for a while) to
not produce errors if they are called. This is partly
because

    use Foo;

is defined to be

    BEGIN {
        require Foo;
        Foo->import();
    }

which would blow up if there is no import function defined in
Foo, for instance if it were defining a class and not a package
which exports modules.

This special case can be broken by simple code like

    \&UNIVERSAL::isa

which will create a stub function which then blows up when it is
used. Notably the module "autouse" which is shipped with perl will
trigger this behavior.

A related issue is that if you ask for a function to be exported
from a module that does not have support for exporting there is no
error, eg:

    use File::Spec qw(catfile);

will silently succeed without exporting a catfile function. This is
exacerbated on case insensitive file systems when the module name
is case-mismatched, the use succeeds but the export does not, leading
to confusion, eg:

    use LIst::Util qw(sum);

will load List::Util but will not export the sum function.

This patch defines UNIVERSAL::import() and UNIVERSAL::unimport()
functions. This prevents the "reference to \&UNIVERSAL::import" bug.
The function is defined to be a no-op unless arguments are passed into
the functions, in which case a fatal exception is thrown indicating
that there is likely a problem. The error is modelled after the
error produced by calling a non-existent method or function:

    ./perl -Ilib -le'BEGIN{ my $import_sub= \&UNIVERSAL::import;}
        use File::Spec qw(catfile);'
    Attempt to call UNIVERSAL::import() with arguments via package File::Spec
        (Perhaps you forgot to load "File::Spec"?) at -e line 1.
    BEGIN failed--compilation aborted at -e line 1.

This fixes Issue #19416, Issue #19417, Issue #19418. See also Issue #19410 for
discussion, however this patch does not fix that case (it may not be
fixable.)
  • Loading branch information
demerphq committed Feb 14, 2022
1 parent 73cf356 commit d58a968
Show file tree
Hide file tree
Showing 5 changed files with 26 additions and 13 deletions.
1 change: 1 addition & 0 deletions Porting/GitUtils.pm
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
#!/usr/bin/perl
package GitUtils;
use strict;
use warnings;
use POSIX qw(strftime);
Expand Down
2 changes: 1 addition & 1 deletion cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
use Test2::Tools::Tiny;
use Test2::Util qw/get_tid USE_THREADS try ipc_separator/;
use File::Temp qw/tempfile/;
use File::Spec qw/catfile/;
use File::Spec;
use List::Util qw/shuffle/;
use strict;
use warnings;
Expand Down
8 changes: 1 addition & 7 deletions gv.c
Original file line number Diff line number Diff line change
Expand Up @@ -1149,13 +1149,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le

gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
if (!gv) {
/* This is the special case that exempts Foo->import and
Foo->unimport from being an error even if there's no
import/unimport subroutine */
if (strEQ(name,"import") || strEQ(name,"unimport")) {
gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
NULL, 0, 0, NULL));
} else if (autoload)
if (autoload)
gv = gv_autoload_pvn(
ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
);
Expand Down
9 changes: 4 additions & 5 deletions t/op/universal.t
Original file line number Diff line number Diff line change
Expand Up @@ -139,9 +139,9 @@ like $@, qr/^Invalid version format/;

my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
if ('a' lt 'A') {
is $subs, "can isa DOES VERSION";
is $subs, "can import isa unimport DOES VERSION";
} else {
is $subs, "DOES VERSION can isa";
is $subs, "DOES VERSION can import isa unimport";
}

ok $a->isa("UNIVERSAL");
Expand All @@ -160,11 +160,10 @@ eval "use UNIVERSAL";
ok $a->isa("UNIVERSAL");

my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
# XXX import being here is really a bug
if ('a' lt 'A') {
is $sub2, "can import isa DOES VERSION";
is $sub2, "can import isa unimport DOES VERSION";
} else {
is $sub2, "DOES VERSION can import isa";
is $sub2, "DOES VERSION can import isa unimport";
}

eval 'sub UNIVERSAL::sleep {}';
Expand Down
19 changes: 19 additions & 0 deletions universal.c
Original file line number Diff line number Diff line change
Expand Up @@ -434,6 +434,23 @@ XS(XS_UNIVERSAL_isa)
}
}

XS(XS_UNIVERSAL_import_unimport); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_import_unimport)
{
dXSARGS;
dXSI32;

if (items > 1) {
char *class_pv= SvPV_nolen(ST(0));
/* _charnames is special - ignore it for now */
if (strNE(class_pv,"_charnames"))
croak("Attempt to call UNIVERSAL::%s() with arguments via package %s (Perhaps you forgot to load \"%s\"?)",
ix ? "unimport" : "import", class_pv, class_pv);
}
XSRETURN_EMPTY;
}


XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_can)
{
Expand Down Expand Up @@ -1253,6 +1270,8 @@ static const struct xsub_details these_details[] = {
{"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
{"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
{"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 },
{"UNIVERSAL::import", XS_UNIVERSAL_import_unimport, NULL, 0},
{"UNIVERSAL::unimport", XS_UNIVERSAL_import_unimport, NULL, 1},
#define VXS_XSUB_DETAILS
#include "vxs.inc"
#undef VXS_XSUB_DETAILS
Expand Down

0 comments on commit d58a968

Please sign in to comment.