File manager

File manager - Edit - /usr/local/cpanel/3rdparty/perl/542/cpanel-lib/x86_64-linux/B/C/OverLoad/B/GV.pm

Back
package # do not index it B::GV; use B::C::Std; use B qw/svref_2object SVf_UTF8/; use B::C::Debug qw/debug verbose/; use B::C::Helpers qw/gv_fetchpv_to_fetchpvn_flags memorizegv/; use B::C::Save qw/savecowpv/; use B::C::Save::Hek qw/save_shared_he get_sHe_HEK/; use B::C::File qw/init init_static_assignments gvsect gpsect xpvgvsect init_bootstraplink/; my %gptable; my $CORE_SYMS = { 'main::ENV' => 'PL_envgv', 'main::ARGV' => 'PL_argvgv', }; # These variables are the proxy variables we will use to save @_ and $_ our $under = ''; our @under = (); sub do_save ( $gv, $name = undef ) { $gv->FLAGS & 2048 and die sprintf( "In B::GV, unexpected SVf_ROK found in %s\n", ref $gv ); if ( $gv->get_fullname =~ qr{::(?:BEGIN\|CHECK\|UNITCHECK)$} ) { # do not save the GV for BEGIN or CHECK if only the CV slot is used if ( ref( $gv->AV ) eq 'B::SPECIAL' && ref( $gv->HV ) eq 'B::SPECIAL' && ref( $gv->SV ) eq 'B::SPECIAL' && ref( $gv->FORM ) eq 'B::SPECIAL' && ref( $gv->IO ) eq 'B::SPECIAL' ) { return q{NULL}; } } # return earlier for special cases return $CORE_SYMS->{ $gv->get_fullname } if $gv->is_coresym(); my ( $ix, $sym ) = gvsect()->reserve($gv); gvsect()->debug( $gv->get_fullname(), $gv ); my $gpsym = $gv->savegp_from_gv(); my $stash_symbol = $gv->get_stash_symbol(); my $namehek = q{NULL}; my $gvname = $gv->NAME; if ( defined $gvname && length($gvname) ) { my ($share_he) = save_shared_he($gvname); $namehek = get_sHe_HEK($share_he); } xpvgvsect()->comment("stash, magic, cur, len, xiv_u={.xivu_namehek=}, xnv_u={.xgv_stash=}"); my $xpvg_ix = xpvgvsect()->saddl( # _XPV_HEAD "%s" => $gv->save_magic_stash($name), # HV* xmg_stash; /* class package / "{%s}" => $gv->save_magic($name), # union _xmgu xmg_u; '%d' => $gv->CUR, # STRLEN xpv_cur; / length of svu_pv as a C string / '{.xpvlenu_len=%d}' => $gv->LEN, # union xpv_len_u - xpvlenu_len or xpvlenu_pv '{.xivu_namehek=(HEK)%s}' => $namehek, # union _xivu xiv_u - the namehek (HEK) '{.xgv_stash=%s}' => $stash_symbol, # union _xnvu xnv_u - The symbol for the HV stash. Which field is it?? ); xpvgvsect()->debug( $gv->get_fullname() ); gvsect()->comment("XPVGV sv_any, U32 sv_refcnt; U32 sv_flags; union { gp* } sv_u # gp"); gvsect()->supdatel( $ix, "&xpvgv_list[%d]" => $xpvg_ix, # XPVGV sv_any "%u" => $gv->REFCNT, # sv_refcnt "0x%x" => $gv->FLAGS, # sv_flags "{.svu_gp=(GP)%s}" => $gpsym, # GP sv_u - plug the gp in our sv_u slot ); memorizegv( $gv->get_fullname(), $sym ); return $sym; } sub get_package ($gv) { return '__ANON__' if ref( $gv->STASH ) eq 'B::SPECIAL'; return $gv->STASH->NAME; } sub is_coresym ($gv) { return $CORE_SYMS->{ $gv->get_fullname() } ? 1 : 0; } sub get_fullname ($gv) { return $gv->get_package() . "::" . $gv->NAME(); } my %saved_gps; # hardcode the order of GV elements, so we can use macro instead of indexes # avoid to count and guess what index we are talking about sub GP_IX_SV() { 0 } sub GP_IX_IO() { 1 } sub GP_IX_CV() { 2 } sub GP_IX_CVGEN () { 3 } sub GP_IX_REFCNT() { 4 } sub GP_IX_HV() { 5 } sub GP_IX_AV() { 6 } sub GP_IX_FORM() { 7 } sub GP_IX_GV() { 8 } sub GP_IX_LINE() { 9 } sub GP_IX_FLAGS() { 10 } sub GP_IX_HEK() { 11 } # FIXME todo and move later to B/GP.pm ? sub savegp_from_gv ($gv) { # no GP to save there... return 'NULL' unless $gv->isGV_with_GP and $gv->GP; # B limitation GP is just a number not a reference so we cannot use objsym / savesym my $gp = $gv->GP; return $saved_gps{$gp} if defined $saved_gps{$gp}; my $gvname = $gv->NAME; my $fullname = $gv->get_fullname; # cannot do this as gp is just a number #my $gpsym = objsym($gp); #return $gpsym if defined $gpsym; # gp fields initializations # gp_cvgen: not set, no B api ( could be done in init section ) my ( $gp_sv, $gp_io, $gp_cv, $gp_cvgen, $gp_hv, $gp_av, $gp_form ) = ( '(SV)&PL_sv_undef', 'NULL', 'NULL', 0, 'NULL', 'NULL', 'NULL' ); my $gp_egv = $gv->save_egv(); my $gp_refcount = $gv->GvREFCNT; # +1 for immortal: do not free our static GVs $gp_refcount-- if $gp_refcount > 1; my $gp_line = $gv->LINE; # we want to use GvLINE from B.xs # present only in perl 5.22.0 and higher. this flag seems unused ( saving 0 for now should be similar ) if ( !$gv->is_empty ) { # S32 INT_MAX $gp_line = $gp_line > 2147483647 ? 4294967294 - $gp_line : $gp_line; } my $gp_flags = $gv->GPFLAGS; # PERL_BITFIELD32 gp_flags:1; ~ unsigned gp_flags:1 die("We know of nothing that compiles with GPFLAGS set. Notifiy BC") if $gp_flags; # gp_file_hek is only saved for non-stashes. my $gp_file_hek = q{NULL}; if ( $fullname !~ /::$/ and $gv->FILE ne 'NULL' ) { # and !$B::C::optimize_cop ($gp_file_hek) = save_shared_he( $gv->FILE ); # use FILE instead of FILEGV or we will save the B::GV stash } my $gp_ix = gpsect()->add('FAKE_GP'); $gp_sv = $gv->save_gv_sv($fullname); $gp_av = $gv->save_gv_av($fullname); $gp_hv = $gv->save_gv_hv($fullname); $gp_cv = $gv->save_gv_cv( $fullname, $gp_ix ); $gp_form = $gv->save_gv_format($fullname); my $io_sv; ( $gp_io, $io_sv ) = $gv->save_gv_io($fullname); $gp_sv = $io_sv if $io_sv; gpsect()->comment('SV, gp_io, CV, cvgen, gp_refcount, HV, AV, CV form, GV, line, flags, HEK* file'); gpsect()->supdatel( $gp_ix, "(SV) %s" => $gp_sv, "(IO) %s" => $gp_io, "(CV) %s" => $gp_cv, "%d" => $gp_cvgen, "%u" => $gp_refcount, "%s" => $gp_hv, "%s" => $gp_av, "(CV) %s" => $gp_form, "(GV) %s / eGV /" => $gp_egv, "%u" => $gp_line, "0x%x" => $gp_flags, "%s" => get_sHe_HEK($gp_file_hek), ); gpsect()->debug( $gv->get_fullname() ); $saved_gps{$gp} = sprintf( "&gp_list[%d]", $gp_ix ); #print STDERR "===== GP:$gp_ix SV:$gp_sv, AV:$gp_av, HV:$gp_hv, CV:$gp_cv \n"; # we can only use static values for sv, av, hv, cv, if they are coming from a static list my @postpone = ( [ 'gp_sv', GP_IX_SV(), $gp_sv ], [ 'gp_av', GP_IX_AV(), $gp_av ], [ 'gp_hv', GP_IX_HV(), $gp_hv ], [ 'gp_cv', GP_IX_CV(), $gp_cv ], ); # Find things that can't be statically compiled and defer them foreach my $check (@postpone) { my ( $field_name, $field_ix, $field_v ) = @$check; # if the value is null or using a static list, then it's fine # when it s a bootstrap XS CV no need to set it later, the init_bootstraplink is going to do it for us (no need to redo it) next if $field_v =~ qr{null}i or $field_v =~ qr{list} or $field_v =~ qr{BOOTSTRAP_XS_}; # replace the value by a null one debug( gv => q{Cannot use static value '%s' for gp_list[%d].%s => postpone to init}, $field_v, $gp_ix, $field_name ); gpsect()->update_field( $gp_ix, $field_ix, 'NULL' ); # postpone the setting to init section my $deferred_init = $field_name eq 'gp_cv' ? init() : init_static_assignments(); $deferred_init->sadd( q{gp_list[%d].%s = %s; / deferred GV initialization for %s /}, $gp_ix, $field_name, $field_v, $fullname ); } return $saved_gps{$gp}; } sub get_stash_symbol ($gv) { my @namespace = split( '::', $gv->get_fullname() ); pop @namespace; my $stash_name = join "::", @namespace; $stash_name .= '::'; no strict 'refs'; return svref_2object( \%{$stash_name} )->save($stash_name); } sub save_egv ($gv) { return q{NULL} if $gv->is_empty; my $egv = $gv->EGV; return q{NULL} if ref($egv) eq 'B::SPECIAL' \|\| ref( $egv->STASH ) eq 'B::SPECIAL'; # if it's the same do a static assignment ? (probably not required) #if ( $$gv == $$egv ) { # warn "Same GV for ??? " . $egv->save; #} return $egv->save; } sub save_gv_sv ( $gv, $fullname ) { my $gvsv = $gv->SV; return 'NULL' unless $$gvsv; if ( $fullname eq 'main::_' ) { $gvsv = svref_2object( \$under ); } return $gvsv->save($fullname); } sub save_gv_av ( $gv, $fullname ) { # new function to be renamed later.. my $gvav = $gv->AV; return 'NULL' unless $gvav && $$gvav; if ( $fullname eq 'main::_' ) { $gvav = svref_2object( \@under ); } my $svsym = $gvav->save($fullname); if ( $fullname eq 'main::-' ) { # fixme: can directly save these values init()->sadd( "AvFILLp(%s) = -1;", $gvav->save ); init()->sadd( "AvMAX(%s) = -1;", $gvav->save ); } return $svsym; } sub save_gv_hv ( $gv, $fullname ) { # new function to be renamed later.. my $gvhv = $gv->HV; return 'NULL' unless $gvhv && $$gvhv; # Handle HV exceptions first... return 'NULL' if $fullname eq 'main::ENV'; # do not save %ENV debug( gv => "GV::save \%$fullname" ); # skip static %Encode::Encoding since 5.20. GH #200. sv_upgrade cannot upgrade itself. # Let it be initialized by boot_Encode/Encode_XSEncodingm with exceptions. # GH #200 and t/testc.sh 75 if ( $fullname eq 'Encode::Encoding' ) { debug( gv => "skip some %Encode::Encoding - XS initialized" ); my %tmp_Encode_Encoding = %Encode::Encoding; %Encode::Encoding = (); # but we need some non-XS encoding keys foreach my $k (qw(utf8 utf-8-strict Unicode Internal Guess)) { $Encode::Encoding{$k} = $tmp_Encode_Encoding{$k} if exists $tmp_Encode_Encoding{$k}; } my $sym = $gvhv->save($fullname); %Encode::Encoding = %tmp_Encode_Encoding; return $sym; } return $gvhv->save($fullname); } sub save_gv_cv ( $gv, $fullname, $gp_ix ) { debug( gv => ".... save_gv_cv $fullname" ); my $package = $gv->get_package(); my $gvcv = $gv->CV; return 'NULL' unless $$gvcv; return 'NULL' unless ref($gvcv) eq 'B::CV'; return 'NULL' if ref( $gvcv->GV ) eq 'B::SPECIAL' or ref( $gvcv->GV->EGV ) eq 'B::SPECIAL'; my $gvname = $gv->NAME(); my $gp = $gv->GP; my $cvsym = 'NULL'; # Can't locate object method "EGV" via package "B::SPECIAL" at /usr/local/cpanel/3rdparty/perl/520/lib/perl5/cpanel_lib/i386-linux-64int/B/C/OverLoad/B/GV.pm line 450. { if ($gp) { $cvsym = $gvcv->save($fullname); } my $origname = $gv->cv_needs_import_after_bootstrap( $cvsym, $fullname ); my $is_exception; # Do not bootsrap ::VERSION to UNIVERSAL::VERSION - GH #74 - use Exporter 5.57 'import' if ( ( $fullname // '' ) =~ qr{::VERSION$} && ( $origname // '' ) eq 'UNIVERSAL::VERSION' ) { $is_exception = 1; } if ( $origname && !$is_exception ) { debug( gv => "bootstrap CV $fullname using $origname\n" ); # Ensure the original XS GV is saved/memorized so it can be found later # In Perl 5.42.0, XS GVs may not be automatically saved during compilation my $orig_gv = eval { B::svref_2object(\{$origname}) }; $orig_gv->save($origname) if $orig_gv; # This will memorize the GV init_bootstraplink()->sadd( 'gp_list[%d].gp_cv = GvCV( %s ); / XS CV %s /', $gp_ix, gv_fetchpv_to_fetchpvn_flags( $origname, 0, 'SVt_PVCV' ), $origname ); } } return $cvsym; } sub cv_needs_import_after_bootstrap ( $gv, $cvsym, $fullname ) { return 0 unless $cvsym && $cvsym =~ m{BOOTSTRAP_XS_\Q[[\E(.+?)\Q]]\E_XS_BOOTSTRAP}; my $bootstrapped_xs_sub = $1; my $package = $gv->CV->GV->STASH->NAME; # is it the same than package earlier ?? my $oname = $gv->CV->GV->NAME; my $origname = $package . "::" . $oname; return '' if $origname =~ m/::__ANON__$/; # How do we bootstrap __ANON__ XSUBs? my $ret = $fullname eq $origname ? '' : $origname; return $ret; } sub save_gv_format ( $gv, $fullname ) { my $gvform = $gv->FORM; return 'NULL' unless $gvform && $$gvform; return $gvform->save($fullname); } sub save_gv_io ( $gv, $fullname ) { # TODO: this one needs sym for now my $gvio = $gv->IO; return 'NULL' unless $$gvio; if ( $fullname =~ m/::DATA$/ ) { no strict 'refs'; my $fh = {$fullname}{IO}; use strict 'refs'; if ( $fh->opened ) { my @read_data = <$fh>; my $data = join '', @read_data; my $is_utf8 = $gv->FLAGS \| SVf_UTF8; # check if the package name is using utf8 or not return $gvio->save_io_and_data( $fullname, $is_utf8, $data ); } # Houston we have a problem there ? } return ( $gvio->save($fullname), undef ); } sub savecv ($gv) { my $package = $gv->STASH->NAME; my $name = $gv->NAME; my $cv = $gv->CV; my $sv = $gv->SV; my $av = $gv->AV; my $hv = $gv->HV; # We Should NEVER compile B::C packages so if we get here, it's a bug. # TODO: Currently breaks xtestc/0350.t and xtestc/0371.t if we make this a die. return if $package eq 'B::C'; my $fullname = $package . "::" . $name; debug( gv => "Checking GV %s 0x%x\n", $fullname, ref $gv ? $$gv : 0 ) if verbose(); # We may be looking at this package just because it is a branch in the # symbol table which is on the path to a package which we need to save # e.g. this is 'Getopt' and we need to save 'Getopt::Long' # return if ( $package ne 'main' and !is_package_used($package) ); return if ( $package eq 'main' and $name =~ /^([^\w].\|_\<.\|INC\|ARGV\|SIG\|ENV\|BEGIN\|main::\|!)$/ ); debug( gv => "GV::savecv - Used GV \$fullname 0x%x", ref $gv ? $$gv : 0 ); debug( gv => "... called from %s", 'B::C::Save'->can('stack_flat')->() ); return unless ( $$cv \|\| $$av \|\| $$sv \|\| $$hv \|\| $gv->IO \|\| $gv->FORM ); if ( $$cv and $name eq 'bootstrap' and $cv->XSUB ) { #return $cv->save($fullname); debug( gv => "Skip XS \&$fullname 0x%x", ref $cv ? $$cv : 0 ); return; } # Dead code? die if $fullname eq 'B::walksymtable' or $fullname eq 'B::C::walksymtable'; $B::C::dumped_package{$package} = 1 if !exists $B::C::dumped_package{$package} and $package !~ /::$/; debug( gv => "Saving GV \*$fullname 0x%x", ref $gv ? $$gv : 0 ); $gv->save($fullname); } sub FULLNAME ($gv) { my $stash = $gv->STASH; # B::SPECIAL means the stash is a NULL. my $stash_name = ref $stash eq 'B::SPECIAL' ? '' : $stash->NAME; my $name = $gv->NAME \|\| ''; return $name if !$stash_name; return $stash_name . '::' . $name; } 1;

| ver. 1.4 | Github | . | PHP 8.1.34 | Generation time: 0.06 | proxy | phpinfo | Settings