gv.c revision 7c478bd95313f5f23a4c958a745db2134aa03244
/* gv.c
*
* Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
/*
* 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
* of your inquisitiveness, I shall spend all the rest of my days answering
* you. What more do you want to know?'
* 'The names of all the stars, and of all living things, and the whole
* history of Middle-earth and Over-heaven and of the Sundering Seas,'
* laughed Pippin.
*/
#include "EXTERN.h"
#define PERL_IN_GV_C
#include "perl.h"
GV *
{
return gv;
}
GV *
{
return gv;
}
GV *
{
return gv;
}
GV *
{
char smallbuf[256];
char *tmpbuf;
if (!PL_defstash)
return Nullgv;
else
tmpbuf[0] = '_';
if (PERLDB_LINE)
}
return gv;
}
void
{
if (proto) {
} else
}
GvMULTI_on(gv);
if (doproto) { /* Replicate part of newSUB here. */
/* XXX unsafe for threads if eval_owner isn't held */
start_subparse(0,0); /* Create CV in compcv. */
#ifdef USE_THREADS
}
#endif /* USE_THREADS */
if (proto) {
}
}
}
STATIC void
{
switch (sv_type) {
case SVt_PVIO:
break;
case SVt_PVAV:
break;
case SVt_PVHV:
break;
}
}
/*
=for apidoc gv_fetchmeth
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
accessible via @ISA and @UNIVERSAL.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
which in the case of success contains an alias for the subroutine, and sets
up caching info for this glob. Similarly for all the searched stashes.
This function grants C<"SUPER"> token as a postfix of the stash name. The
GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
visible to Perl code. So when calling C<call_sv>, you should not use
the GV directly; instead, you should use the method's CV, which can be
obtained from the GV with the C<GvCV> macro.
=cut
*/
GV *
{
if (!stash)
return 0;
if (!gvp)
else {
/* If genuine method or valid cache entry, use it */
return topgv;
/* Stale cached entry: junk it */
}
return 0; /* cache indicates sub doesn't exist */
}
/* create and re-create @.*::SUPER::ISA on demand */
packlen -= 7;
}
}
}
if (av) {
/* NOTE: No support for tied ISA */
while (items--) {
if (!basestash) {
continue;
}
if (gv)
goto gotcha;
}
}
/* if at top level, try UNIVERSAL */
HV* lastchance;
{
/*
* Cache method in topgv if:
* 1. topgv has no synonyms (else inheritance crosses wires)
* 2. method isn't a stub (else AUTOLOAD fails spectacularly)
*/
if (topgv &&
{
}
return gv;
}
/* cache the fact that the method is not defined */
}
}
}
return 0;
}
/*
=for apidoc gv_fetchmethod
See L<gv_fetchmethod_autoload>.
=cut
*/
GV *
{
}
/*
=for apidoc gv_fetchmethod_autoload
Returns the glob which contains the subroutine to call to invoke the method
on the C<stash>. In fact in the presence of autoloading this may be the
glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
already setup.
The third parameter of C<gv_fetchmethod_autoload> determines whether
AUTOLOAD lookup is performed if the given method is not present: non-zero
means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
with a non-zero C<autoload> parameter.
These functions grant C<"SUPER"> token as a prefix of the method name. Note
that if you want to keep the returned glob for a long time, you need to
check for it being "AUTOLOAD", since at the later time the call may load a
different subroutine due to $AUTOLOAD changing its value. Use the glob
created via a side effect to do this.
These functions have the same side-effects and as C<gv_fetchmeth> with
C<level==0>. C<name> should be writable if contains C<':'> or C<'
''>. The warning against passing the GV returned by C<gv_fetchmeth> to
C<call_sv> apply equally to these functions.
=cut
*/
GV *
{
register const char *nend;
const char *nsplit = 0;
if (*nend == '\'')
}
if (nsplit) {
if (*nsplit == ':')
--nsplit;
/* ->SUPER::method should really be looked up in original stash */
CopSTASHPV(PL_curcop)));
}
else
}
if (!gv) {
else if (autoload)
}
else if (autoload) {
else {
}
if (autogv)
}
}
return gv;
}
GV*
{
static char autoload[] = "AUTOLOAD";
return Nullgv;
return Nullgv;
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
* The subroutine's original name may not be "AUTOLOAD", so we don't
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
#ifdef USE_THREADS
#endif
#ifdef USE_THREADS
#endif
return gv;
}
/*
=for apidoc gv_stashpv
Returns a pointer to the stash for a specified package. C<name> should
be a valid UTF-8 string. If C<create> is set then the package will be
created if it does not already exist. If C<create> is not set and the
package does not exist then NULL is returned.
=cut
*/
HV*
{
}
HV*
{
char smallbuf[256];
char *tmpbuf;
else
if (!tmpgv)
return 0;
return stash;
}
/*
=for apidoc gv_stashsv
Returns a pointer to the stash for a specified package, which must be a
valid UTF-8 string. See C<gv_stashpv>.
=cut
*/
HV*
{
register char *ptr;
}
GV *
{
register const char *namend;
name++;
{
if (!stash)
stash = PL_defstash;
return Nullgv;
if (len > 0) {
char smallbuf[256];
char *tmpbuf;
else
else
GvMULTI_on(gv);
}
return Nullgv;
}
if (*namend == ':')
namend++;
namend++;
if (!*name)
}
}
if (!len)
len = 1;
/* No stash in name, so see how we can default */
if (!stash) {
if (isIDFIRST_lazy(name)) {
if (*name == 'S' && (
else if (*name == 'A' && (
}
if (global)
stash = PL_defstash;
stash = PL_curstash;
{
if (!gvp ||
{
stash = 0;
}
{
name);
stash = 0;
}
}
}
else
}
else
stash = PL_defstash;
}
/* By this point we should have a stash and a name */
if (!stash) {
if (add) {
"Global symbol \"%s%s\" requires explicit package name",
: ""), name));
}
else
return Nullgv;
}
return Nullgv;
return Nullgv;
if (add) {
GvMULTI_on(gv);
}
return gv;
return gv;
}
/* Adding a new symbol */
GvMULTI_on(gv) ;
/* set up magic where warranted */
switch (*name) {
case 'A':
}
break;
case 'E':
GvMULTI_on(gv);
break;
case 'I':
GvMULTI_on(gv);
/* NOTE: No support for tied ISA */
{
char *pname;
}
}
break;
case 'O':
GvMULTI_on(gv);
}
break;
case 'S':
I32 i;
if (!PL_psig_ptr) {
}
GvMULTI_on(gv);
for (i = 1; PL_sig_name[i]; i++) {
if (init)
PL_psig_ptr[i] = 0;
PL_psig_name[i] = 0;
}
}
break;
case 'V':
GvMULTI_on(gv);
break;
case '&':
if (len > 1)
break;
goto ro_magicalize;
case '`':
if (len > 1)
break;
goto ro_magicalize;
case '\'':
if (len > 1)
break;
goto ro_magicalize;
case ':':
if (len > 1)
break;
goto magicalize;
case '?':
if (len > 1)
break;
#ifdef COMPLEX_STATUS
#endif
goto magicalize;
case '!':
if (len > 1)
break;
dSP;
require_pv("Errno.pm");
}
}
goto magicalize;
case '-':
if (len > 1)
break;
else {
}
goto magicalize;
case '#':
case '*':
/* FALL THROUGH */
case '[':
case '^':
case '~':
case '=':
case '%':
case '.':
case '(':
case ')':
case '<':
case '>':
case ',':
case '\\':
case '/':
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
case '\005': /* $^E */
case '\006': /* $^F */
case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
case '\017': /* $^O */
case '\020': /* $^P */
case '\024': /* $^T */
if (len > 1)
break;
goto magicalize;
case '|':
if (len > 1)
break;
goto magicalize;
case '\023': /* $^S */
if (len > 1)
break;
goto ro_magicalize;
case '\027': /* $^W & $^WARNING_BITS */
break;
goto magicalize;
case '+':
if (len > 1)
break;
else {
}
/* FALL THROUGH */
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
break;
case '\014': /* $^L */
if (len > 1)
break;
break;
case ';':
if (len > 1)
break;
break;
case ']':
if (len == 1) {
#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
"%8.6"
#else
"%5.3"
#endif
NVff,
}
break;
case '\026': /* $^V */
if (len == 1) {
}
break;
}
return gv;
}
void
{
if (!hv) {
return;
}
}
}
void
{
if (!hv) {
return;
}
}
void
{
if (!egv)
}
void
{
if (!egv)
}
/* XXX compatibility with versions <= 5.003. */
void
{
}
/* XXX compatibility with versions <= 5.003. */
void
{
}
IO *
{
/* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
return io;
}
void
{
register I32 i;
return;
{
}
char *file;
continue;
/* performance hack: if filename is absolute and it's a standard
* module, don't bother warning */
if (file
{
continue;
}
#ifdef USE_ITHREADS
#else
#endif
"Name \"%s::%s\" used only once: possible typo",
}
}
}
}
GV *
{
}
/* hopefully this is only called on local symbol table entries */
GP*
{
if (!gp)
/* multi-named GPs cannot be used for method cache */
}
else {
/* Adding a new name to a subroutine invalidates method cache */
}
}
return gp;
}
void
{
return;
if (ckWARN_d(WARN_INTERNAL))
"Attempt to free unreferenced glob pointers");
return;
}
/* Deleting the name of a subroutine invalidates method cache */
}
return;
}
}
#define MICROPORT
#endif
#ifdef MICROPORT /* Microport 2.4 hack */
{
else
}
{
else
}
#endif /* Microport 2.4 hack */
/* Updates and caches the CV's */
bool
{
#ifdef OVERLOAD_VIA_HASH
#endif
return AMT_AMAGIC(amtp);
int i;
for (i=1; i<NofAMmeth; i++) {
}
}
}
#ifdef OVERLOAD_VIA_HASH
int filled=0;
int i;
char *cp;
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
if (( cp = (char *)PL_AMG_names[0] ) &&
}
for (i = 1; i < NofAMmeth; i++) {
cv = 0;
cp = (char *)PL_AMG_names[i];
default:
break;
}
break;
/* FALL THROUGH */
case SVt_PVHV:
case SVt_PVAV:
return FALSE;
case SVt_PVCV:
break;
case SVt_PVGV:
break;
}
else {
return FALSE;
}
}
#else
{
int filled = 0;
int i;
const char *cp;
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
if ((cp = PL_AMG_names[0])) {
/* Try to find via inheritance. */
if (gv)
if (!gv)
goto no_table;
}
for (i = 1; i < NofAMmeth; i++) {
/* don't fill the cache while looking up! */
cv = 0;
/* GvSV contains the name of the method. */
FALSE)))
{
/* Can be an import stub (created by `can'). */
} else
}
}
filled = 1;
}
#endif
}
if (filled) {
AMT_AMAGIC_on(&amt);
return TRUE;
}
}
/* Here we have no table: */
return FALSE;
}
SV*
{
* usual method */
} else {
int logic;
/* look for substituted methods */
/* In all the covered cases we should be called with assign==0. */
switch (method) {
case inc_amg:
force_cpy = 1;
}
break;
case dec_amg:
force_cpy = 1;
}
break;
case bool__amg:
break;
case numer_amg:
break;
case string_amg:
break;
case not_amg:
postpr = 1;
break;
case copy_amg:
{
/*
* SV* ref causes confusion with the interpreter variable of
* the same name
*/
/*
* Just to be extra cautious. Maybe in some
* additional cases sv_setsv is safe, too.
*/
return newref;
}
}
break;
case abs_amg:
} else {
}
if (logic) {
lr = 1;
}
} else {
return left;
}
}
break;
case neg_amg:
lr = 1;
}
break;
case iter_amg: /* XXXX Eventually should do to_gv. */
/* FAIL safe */
return NULL; /* Delegate operation to standard mechanisms. */
break;
case to_sv_amg:
case to_av_amg:
case to_hv_amg:
case to_gv_amg:
case to_cv_amg:
/* FAIL safe */
return left; /* Delegate operation to standard mechanisms. */
break;
default:
goto not_found;
}
* argument found */
lr=1;
&& !(flags & AMGf_unary)) {
/* We look for substitution for
* comparison operations and
* concatenation */
return NULL; /* Delegate operation to string conversion */
}
off = -1;
switch (method) {
case lt_amg:
case le_amg:
case gt_amg:
case ge_amg:
case eq_amg:
case ne_amg:
case slt_amg:
case sle_amg:
case sgt_amg:
case sge_amg:
case seq_amg:
case sne_amg:
}
if (!cv) {
goto not_found;
}
} else {
not_found: /* No method found, either report or croak */
switch (method) {
case to_sv_amg:
case to_av_amg:
case to_hv_amg:
case to_gv_amg:
case to_cv_amg:
/* FAIL safe */
return left; /* Delegate operation to standard mechanisms. */
break;
}
} else {
"Operation `%s': no method found,%sargument %s%s%s%s",
"in overloaded package ":
"has no overloaded magic",
"",
",\n\tright argument in overloaded package ":
(flags & AMGf_unary
? ""
: ",\n\tright argument has no overloaded magic"),
""));
} else {
}
return NULL;
}
}
}
if (!notfound) {
"Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
" (initially `",
}
/* Since we use shallow copy during assignment, we need
* to dublicate the contents, probably calling user-supplied
* version of copy operator
*/
/* We need to copy in following cases:
* a) Assignment form was called.
* assignshift==1, assign==T, method + 1 == off
* b) Increment or decrement, called directly.
* assignshift==0, assign==0, method + 0 == off
* assignshift==0, assign==T,
* force_cpy == T
* d) Increment or decrement, translated to nomethod.
* assignshift==0, assign==0,
* force_cpy == T
* e) Assignment form translated to nomethod.
* assignshift==1, assign==T, method + 1 != off
* force_cpy == T
*/
/* off is method, method+assignshift, or a result of opcode substitution.
* In the latter case assignshift==0, so only notfound case is important.
*/
|| force_cpy)
{
dSP;
SAVEOP();
pp_pushmark();
if (notfound) {
}
if (postpr) {
int ans;
switch (method) {
case le_amg:
case sle_amg:
case lt_amg:
case slt_amg:
case ge_amg:
case sge_amg:
case gt_amg:
case sgt_amg:
case eq_amg:
case seq_amg:
case ne_amg:
case sne_amg:
case inc_amg:
case dec_amg:
case not_amg:
}
}
} else {
return res;
}
}
}
/*
=for apidoc is_gv_magical
Returns C<TRUE> if given the name of a magical GV.
Currently only useful internally when determining if a GV should be
created even in rvalue contexts.
C<flags> is not used at present but available for future extension to
allow selecting particular classes of magical variable.
=cut
*/
bool
{
if (!len)
return FALSE;
switch (*name) {
case 'I':
goto yes;
break;
case 'O':
goto yes;
break;
case 'S':
goto yes;
break;
case '\027': /* $^W & $^WARNING_BITS */
if (len == 1
{
goto yes;
}
break;
case '&':
case '`':
case '\'':
case ':':
case '?':
case '!':
case '-':
case '#':
case '*':
case '[':
case '^':
case '~':
case '=':
case '%':
case '.':
case '(':
case ')':
case '<':
case '>':
case ',':
case '\\':
case '/':
case '|':
case '+':
case ';':
case ']':
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
case '\005': /* $^E */
case '\006': /* $^F */
case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
case '\014': /* $^L */
case '\017': /* $^O */
case '\020': /* $^P */
case '\023': /* $^S */
case '\024': /* $^T */
case '\026': /* $^V */
if (len == 1)
goto yes;
break;
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
if (len > 1) {
return FALSE;
}
}
yes:
return TRUE;
default:
break;
}
return FALSE;
}