File manager

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

Back
package # do not index it B::PVMG; use B::C::Std; use B::C::Debug qw/debug verbose WARN/; use B qw/SVf_IsCOW SVf_READONLY cchar SVp_POK svref_2object/; use B::C::Save qw/savecowpv/; use B::C::Decimal qw/get_integer_value get_double_value/; use B::C::File qw/init init_static_assignments svsect xpvmgsect magicsect init_vtables/; # usually 0x400000, but can be as low as 0x10000 # http://docs.embarcadero.com/products/rad_studio/delphiAndcpp2009/HelpUpdate2/EN/html/devcommon/compdirsimagebaseaddress_xml.html # called mapped_base on linux (usually 0xa38000) sub LOWEST_IMAGEBASE() { 0x10000 } sub do_save ( $sv, $fullname = undef ) { my ( $ix, $sym ) = svsect()->reserve($sv); svsect()->debug( $fullname, $sv ); my ( $sv_u, $cur, $len, $pv, $flags ); if ( $fullname =~ m{^main::[1-9][0-9]$} ) { # Only modify $1,$2, ... etc. $0 is magic $flags = $sv->FLAGS; $flags \|= SVf_IsCOW; # flag it as COW as we are using the generic empty string $pv = ""; ( $sv_u, $cur, $len ) = savecowpv($pv); $sv_u = ".svu_pv=(char) $sv_u"; } else { ( $sv_u, $cur, $len, $pv, $flags ) = $sv->save_svu( $sym, $sym, $fullname ); } my $ivx = get_integer_value( $sv->IVX ); # XXX How to detect HEK* namehek? my $nvx = get_double_value( $sv->NVX ); # it cannot be xnv_u.xgv_stash ptr (BTW set by GvSTASH later) # See #305 Encode::XS: XS objects are often stored as SvIV(SvRV(obj)). The real # address needs to be patched after the XS object is initialized. # But how detect them properly? # Detect ptr to extern symbol in shared library and remap it in init2 # Safe and mandatory currently only Net-DNS-0.67 - 0.74. # svop const or pad OBJECT,IOK if ( # fixme simply the or logic ( ( $fullname and $fullname =~ /^svop const\|^padop\|^Encode::Encoding\| :pad\[1\]/ ) ) and $ivx > LOWEST_IMAGEBASE # some crazy heuristic for a sharedlibrary ptr in .data (> image_base) and ref( $sv->SvSTASH ) ne 'B::SPECIAL' ) { # restore the old _patch_dlsym which is updating pointer to C functions $ivx = _patch_dlsym( $sv, $fullname, $ivx ); } xpvmgsect()->comment("STASH, MAGIC, cur, len, xiv_u, xnv_u"); my $xpvmg_ix = xpvmgsect()->sadd( "(HV) %s, {%s}, %u, {%u}, {%s}, {%s}", $sv->save_magic_stash, $sv->save_magic($fullname), $cur, $len, $ivx, $nvx ); my $sv_ix = svsect()->supdate( $ix, "&xpvmg_list[%d], %Lu, 0x%x, {%s}", $xpvmg_ix, $sv->REFCNT, $flags, $sv_u ); return $sym; } # https://metacpan.org/pod/distribution/perl/pod/perlguts.pod my $perl_magic_vtable_map = { # There is no corresponding PL_vtbl_ for these entries. '%' => undef, # Extra data for restricted hashes - PERL_MAGIC_rhash ':' => undef, # Extra data for symbol tables - toke.c - PERL_MAGIC_symtab 'L' => undef, # Debugger %_<filename - PERL_MAGIC_dbfile 'S' => undef, # %SIG hash - PERL_MAGIC_sig 'V' => undef, # SV was vstring literal - PERL_MAGIC_vstring # Die if we get these? Strip the magic and hope bootstrap puts them back?? 'u' => 0, # Reserved for use by extensions - PERL_MAGIC_uvar_elem '~' => 0, # Available for use by extensions - PERL_MAGIC_ext # All of these are PL_vtbl_$value so easily assigned on startup. chr(0) => 'sv', # Special scalar variable ( \0 ) '#' => 'arylen', # Array length ($#ary) '' => 'debugvar', # $DB::single, signal, trace vars '.' => 'pos', # pos() lvalue '<' => 'backref', # For weak ref data '@' => 'arylen_p', # To move arylen out of XPVAV 'B' => 'bm', # Boyer-Moore (fast string search) 'c' => 'ovrld', # Holds overload table (AMT) on stash - PERL_MAGIC_overload_table 'D' => 'regdata', # Regex match position data (@+ and @- vars) 'd' => 'regdatum', # Regex match position data element 'E' => 'env', # %ENV hash 'e' => 'envelem', # %ENV hash element 'f' => 'fm', # Formline ('compiled' format) 'g' => 'mglob', # m//g target - PERL_MAGIC_regex_global 'H' => 'hints', # %^H hash 'h' => 'hintselem', # %^H hash element 'I' => 'isa', # @ISA array 'i' => 'isaelem', # @ISA array element 'k' => 'nkeys', # scalar(keys()) lvalue 'l' => 'dbline', # Debugger %_<filename element 'N' => 'shared', # Shared between threads 'n' => 'shared_scalar', # Shared between threads 'o' => 'collxfrm', # Locale transformation 'P' => 'pack', # Tied array or hash - PERL_MAGIC_tied 'p' => 'packelem', # Tied array or hash element - PERL_MAGIC_tiedelem 'q' => 'packelem', # Tied scalar or handle - PERL_MAGIC_tiedscalar 'r' => 'regexp', # Precompiled qr// regex - PERL_MAGIC_qr 's' => 'sigelem', # %SIG hash element 't' => 'taint', # Taintedness 'U' => 'uvar', # Available for use by extensions 'v' => 'vec', # vec() lvalue 'w' => 'utf8', # Cached UTF-8 information 'x' => 'substr', # substr() lvalue 'y' => 'defelem', # Shadow "foreach" iterator variable smart parameter vivification 'Y' => 'nonelem', # Array element that does not exist - introduced in 5.28 '\\' => 'lvref', # Lvalue reference constructor ']' => 'checkcall', # Inlining/mutation of call to this CV }; sub save_magic ( $sv, $fullname ) { my $sv_flags = $sv->FLAGS; my $pkg; # Protect our SVs against non-magic or SvPAD_OUR. Fixes tests 16 and 14 + 23 return '0' if ( !$sv->MAGICAL ); my @mgchain = $sv->MAGIC; my $last_magic = '0'; foreach my $mg ( reverse @mgchain ) { # reverse because we're assigning down the chain, not up. my $type = $mg->TYPE; my $ptr = $mg->BCPTR; my $len = $mg->LENGTH; exists $perl_magic_vtable_map->{$type} or die sprintf( "Unknown magic type '0x%s' / '%s' [check your mapping table dude]", unpack( 'H', $type ), $type ); my $vtable = $perl_magic_vtable_map->{$type}; if ( defined $vtable and $vtable eq '0' ) { next; # Remove the next above and Moose (xtestc/0350.t and xtestc/0371.t will exit B::C over this.) warn("We don't know how to handle or what uses u or ~ magic ???\n"); warn("Got ptr == $ptr\n"); warn("Got len == $len\n"); warn("Got type == $type\n"); exit 6; } ### view Perl_magic_freeovrld: contains a list of memory addresses to CVs... ### the first call to Gv_AMG should recompute the cache ### we are saving (( and other '(' overload methods, like for example ("" for the str overload ### maybe we simply want to run Gv_AMG on the stash at init time next if $type eq 'c'; # Save the object if there is one. my $obj = '0'; if ( $type !~ /^[rnD]$/ ) { my $o = $mg->OBJ; $obj = $o->save($fullname) if ( ref $o ne 'SCALAR' ); } elsif ( $type eq 'D' ) { # For D Magic, this number is not a pointer. It corresponds to the char value of the variable # i.e. char 43 == '+' for @+ $obj = $mg->OBJ_PTR(); } my $ptrsv = '0'; my $init_ptrsv; { # was if $len == HEf_SVKEY # The pointer is an SV* ('s' sigelem e.g.) # XXX On 5.6 ptr might be a SCALAR ref to the PV, which was fixed later if ( !defined $ptr ) { $ptrsv = '0'; } elsif ( ref($ptr) eq 'SCALAR' ) { warn("We don't think anything happens here. Contact us if your program doesn't compile because of this.;\n"); exit 7; $init_ptrsv = "SvPVX(" . svref_2object($ptr)->save($fullname) . ")"; } elsif ( ref $ptr ) { # Certain magic type actually point to a PMOP or a SVPV. We save them here. # NOTE: This is thanks to BCPTR which needs to backport to B.xs $ptrsv = ref $ptr =~ m/OP/ ? $ptr->save() : $ptr->save($fullname); } else { ( $ptrsv, undef, undef ) = savecowpv($ptr) if defined $ptr; } } magicsect->comment('mg_moremagic, mg_virtual, mg_private, mg_type, mg_flags, mg_len, mg_obj, mg_ptr'); my $last_magic_ix = magicsect->saddl( '(MAGIC) %s' => $last_magic, # mg_moremagic '(MGVTBL) %s' => '0', # mg_virtual '%s' => $mg->PRIVATE, # mg_private '%s' => cchar($type), # mg_type '0x%x' => $mg->FLAGS, # mg_flags '%s' => $len, # mg_len '(SV) %s' => $obj, # mg_obj '(char) %s' => $ptrsv, # mg_ptr ); $last_magic = sprintf( 'magic_list[%d]', $last_magic_ix ); if ($init_ptrsv) { init_static_assignments()->sadd( q{%s.mg_ptr = (char) %s;}, $last_magic, $init_ptrsv ); } if ($vtable) { # simplified version #init_vtables()->sadd( 'magic_list[%d].mg_virtual = (MGVTBL) &PL_vtbl_%s;', $last_magic_ix, $vtable ); # taking care of the group init_vtables()->add_pvmg( $last_magic_ix, $vtable ); } $last_magic = "&" . $last_magic; } return $last_magic; } sub save_magic_stash { my $sv = shift or die("save_magic_stash is a method call!"); my $symbol = $sv->SvSTASH->save \|\| return q{0}; return q{0} if $symbol eq 'Nullsv'; return q{0} if $symbol eq 'Nullhv'; return "(HV) $symbol"; } ### # TODO: This was added to PVMG because we thought it was only used in this op but # as of 5.18, it's used in B::CV::save sub _patch_dlsym ( $sv, $fullname, $ivx ) { my $pkg = ''; if ( ref($sv) eq 'B::PVMG' ) { my $stash = $sv->SvSTASH; $pkg = $stash->can('NAME') ? $stash->NAME : ''; } my $name = $sv->FLAGS & SVp_POK() ? $sv->PVX : ""; my $ivxhex = sprintf( "0x%x", $ivx ); # lazy load encode after walking the optree if ( $pkg eq 'Encode::XS' ) { $pkg = 'Encode'; if ( $fullname eq 'Encode::Encoding{iso-8859-1}' ) { $name = "iso8859_1_encoding"; } elsif ( $fullname eq 'Encode::Encoding{null}' ) { $name = "null_encoding"; } elsif ( $fullname eq 'Encode::Encoding{ascii-ctrl}' ) { $name = "ascii_ctrl_encoding"; } elsif ( $fullname eq 'Encode::Encoding{ascii}' ) { $name = "ascii_encoding"; } if ( $name and $name =~ /^(ascii\|ascii_ctrl\|iso8859_1\|null)/ ) { my $enc = 'Encode'->can('find_encoding')->($name); $name .= "_encoding" unless $name =~ /_encoding$/; $name =~ s/-/_/g; verbose("$pkg $Encode::VERSION with remap support for $name (find 1)"); } else { for my $n ( Encode::encodings() ) { # >=5.16 constsub without name my $enc = Encode::find_encoding($n); if ( $enc and ref($enc) ne 'Encode::XS' ) { # resolve alias such as Encode::JP::JIS7=HASH(0x292a9d0) $pkg = ref($enc); $pkg =~ s/^(Encode::\w+)(::.)/$1/; # collapse to the @dl_module name $enc = Encode->find_alias($n); } if ( $enc and ref($enc) eq 'Encode::XS' and $sv->IVX == $$enc ) { $name = $n; $name =~ s/-/_/g; $name .= "_encoding" if $name !~ /_encoding$/; if ( $pkg ne 'Encode' ) { verbose( "saving $pkg" . "::bootstrap" ); svref_2object( \&{"$pkg\::bootstrap"} )->save; } last; } } if ($name) { verbose("$pkg $Encode::VERSION remap found for constant $name"); } else { WARN("Warning: Possible missing remap for compile-time XS symbol in $pkg $fullname $ivxhex [#305]"); } } } elsif ( $pkg eq 'Net::LibIDN' ) { $name = "idn_to_ascii"; } # new API (only Encode so far) if ( $pkg and $name and $name =~ /^[a-zA-Z_0-9-]+$/ ) { # valid symbol name # unfortunately cannot use our BOOTSTRAP_XS logic there as # Perl_gv_fetchpv("Encode::ascii_encoding", 0, SVt_PVCV) # is going to return an 0 # need to use the dlopen + dlsym method my $id = xpvmgsect()->index + 1; verbose("add remap for ${pkg}: $name $ivxhex in xpvmg_list[$id]"); $B::C::remap_xs_symbols{$pkg}{MG} //= []; push @{ $B::C::remap_xs_symbols{$pkg}{MG} }, { NAME => $name, ID => $id }; $ivx = "0UL /* remap $ivxhex => $name */"; } else { WARN("Warning: Possible missing remap for compile-time XS symbol in $pkg $fullname $ivx [#305]"); } return $ivx; } 1;

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