x3x3x3x_5h3ll
— 53cur3 — 5h3ll_1d —
Linux vps-10654784.cedaps.org.br 3.10.0-1160.119.1.el7.x86_64 #1 SMP Tue Jun 4 14:43:51 UTC 2024 x86_64
  INFO SERVER : Apache PHP : 7.4.33
/lib64/perl5/vendor_perl/DBI/
162.240.100.168

 
[ NAME ] [ SIZE ] [ PERM ] [ DATE ] [ ACTN ]
+FILE +DIR
Const dir drwxr-xr-x 2023-04-05 00:01 R D
DBD dir drwxr-xr-x 2023-04-05 00:01 R D
Gofer dir drwxr-xr-x 2023-04-05 00:01 R D
ProfileDumper dir drwxr-xr-x 2023-04-05 00:01 R D
SQL dir drwxr-xr-x 2023-04-05 00:01 R D
Util dir drwxr-xr-x 2023-04-05 00:01 R D
  Changes.pm 111.055 KB -rw-r--r-- 2014-06-10 01:06 R E G D
  DBD.pm 122.994 KB -rw-r--r-- 2013-04-04 22:17 R E G D
  FAQ.pm 34.378 KB -rw-r--r-- 2013-04-04 22:17 R E G D
  Profile.pm 31.747 KB -rw-r--r-- 2013-04-04 22:17 R E G D
  ProfileData.pm 19.633 KB -rw-r--r-- 2013-04-04 22:17 R E G D
  ProfileDumper.pm 10.187 KB -rw-r--r-- 2013-04-04 22:17 R E G D
  ProfileSubs.pm 1.18 KB -rw-r--r-- 2013-04-04 22:17 R E G D
  ProxyServer.pm 25.84 KB -rw-r--r-- 2014-06-10 01:06 R E G D
  PurePerl.pm 37.038 KB -rw-r--r-- 2013-04-04 22:17 R E G D
REQUEST EXIT
######################################################################## package # hide from PAUSE DBI; # vim: ts=8:sw=4 ######################################################################## # # Copyright (c) 2002,2003 Tim Bunce Ireland. # # See COPYRIGHT section in DBI.pm for usage and distribution rights. # ######################################################################## # # Please send patches and bug reports to # # Jeff Zucker with cc to # ######################################################################## use strict; use Carp; require Symbol; require utf8; *utf8::is_utf8 = sub { # hack for perl 5.6 require bytes; return unless defined $_[0]; return !(length($_[0]) == bytes::length($_[0])) } unless defined &utf8::is_utf8; $DBI::PurePerl = $ENV{DBI_PUREPERL} || 1; $DBI::PurePerl::VERSION = sprintf("2.%06d", q$Revision: 14285 $ =~ /(\d+)/o); $DBI::neat_maxlen ||= 400; $DBI::tfh = Symbol::gensym(); open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!"; select( (select($DBI::tfh), $| = 1)[0] ); # autoflush # check for weaken support, used by ChildHandles my $HAS_WEAKEN = eval { require Scalar::Util; # this will croak() if this Scalar::Util doesn't have a working weaken(). Scalar::Util::weaken( my $test = [] ); 1; }; %DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err); use constant SQL_ALL_TYPES => 0; use constant SQL_ARRAY => 50; use constant SQL_ARRAY_LOCATOR => 51; use constant SQL_BIGINT => (-5); use constant SQL_BINARY => (-2); use constant SQL_BIT => (-7); use constant SQL_BLOB => 30; use constant SQL_BLOB_LOCATOR => 31; use constant SQL_BOOLEAN => 16; use constant SQL_CHAR => 1; use constant SQL_CLOB => 40; use constant SQL_CLOB_LOCATOR => 41; use constant SQL_DATE => 9; use constant SQL_DATETIME => 9; use constant SQL_DECIMAL => 3; use constant SQL_DOUBLE => 8; use constant SQL_FLOAT => 6; use constant SQL_GUID => (-11); use constant SQL_INTEGER => 4; use constant SQL_INTERVAL => 10; use constant SQL_INTERVAL_DAY => 103; use constant SQL_INTERVAL_DAY_TO_HOUR => 108; use constant SQL_INTERVAL_DAY_TO_MINUTE => 109; use constant SQL_INTERVAL_DAY_TO_SECOND => 110; use constant SQL_INTERVAL_HOUR => 104; use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111; use constant SQL_INTERVAL_HOUR_TO_SECOND => 112; use constant SQL_INTERVAL_MINUTE => 105; use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113; use constant SQL_INTERVAL_MONTH => 102; use constant SQL_INTERVAL_SECOND => 106; use constant SQL_INTERVAL_YEAR => 101; use constant SQL_INTERVAL_YEAR_TO_MONTH => 107; use constant SQL_LONGVARBINARY => (-4); use constant SQL_LONGVARCHAR => (-1); use constant SQL_MULTISET => 55; use constant SQL_MULTISET_LOCATOR => 56; use constant SQL_NUMERIC => 2; use constant SQL_REAL => 7; use constant SQL_REF => 20; use constant SQL_ROW => 19; use constant SQL_SMALLINT => 5; use constant SQL_TIME => 10; use constant SQL_TIMESTAMP => 11; use constant SQL_TINYINT => (-6); use constant SQL_TYPE_DATE => 91; use constant SQL_TYPE_TIME => 92; use constant SQL_TYPE_TIMESTAMP => 93; use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95; use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94; use constant SQL_UDT => 17; use constant SQL_UDT_LOCATOR => 18; use constant SQL_UNKNOWN_TYPE => 0; use constant SQL_VARBINARY => (-3); use constant SQL_VARCHAR => 12; use constant SQL_WCHAR => (-8); use constant SQL_WLONGVARCHAR => (-10); use constant SQL_WVARCHAR => (-9); # for Cursor types use constant SQL_CURSOR_FORWARD_ONLY => 0; use constant SQL_CURSOR_KEYSET_DRIVEN => 1; use constant SQL_CURSOR_DYNAMIC => 2; use constant SQL_CURSOR_STATIC => 3; use constant SQL_CURSOR_TYPE_DEFAULT => SQL_CURSOR_FORWARD_ONLY; use constant IMA_HAS_USAGE => 0x0001; #/* check parameter usage */ use constant IMA_FUNC_REDIRECT => 0x0002; #/* is $h->func(..., "method")*/ use constant IMA_KEEP_ERR => 0x0004; #/* don't reset err & errstr */ use constant IMA_KEEP_ERR_SUB => 0x0008; #/* '' if in nested call */ use constant IMA_NO_TAINT_IN => 0x0010; #/* don't check for tainted args*/ use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */ use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */ use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */ use constant IMA_STUB => 0x0100; #/* donothing eg $dbh->connected */ use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */ use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement */ use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */ use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */ use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/ use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */ use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */ use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before call */ use constant DBIstcf_STRICT => 0x0001; use constant DBIstcf_DISCARD_STRING => 0x0002; my %is_flag_attribute = map {$_ =>1 } qw( Active AutoCommit ChopBlanks CompatMode Executed Taint TaintIn TaintOut InactiveDestroy AutoInactiveDestroy LongTruncOk MultiThread PrintError PrintWarn RaiseError ShowErrorStatement Warn ); my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw( ActiveKids Attribution BegunWork CachedKids Callbacks ChildHandles CursorName Database DebugDispatch Driver Err Errstr ErrCount FetchHashKeyName HandleError HandleSetErr ImplementorClass Kids LongReadLen NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash NULLABLE NUM_OF_FIELDS NUM_OF_PARAMS Name PRECISION ParamValues Profile Provider ReadOnly RootClass RowCacheSize RowsInCache SCALE State Statement TYPE Type TraceLevel Username Version )); sub valid_attribute { my $attr = shift; return 1 if $is_valid_attribute{$attr}; return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter return 0 } my $initial_setup; sub initial_setup { $initial_setup = 1; print $DBI::tfh __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n" if $DBI::dbi_debug & 0xF; untie $DBI::err; untie $DBI::errstr; untie $DBI::state; untie $DBI::rows; #tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean } sub _install_method { my ( $caller, $method, $from, $param_hash ) = @_; initial_setup() unless $initial_setup; my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/; my $bitmask = $param_hash->{'O'} || 0; my @pre_call_frag; return if $method_name eq 'can'; push @pre_call_frag, q{ # ignore DESTROY for outer handle (DESTROY for inner likely to follow soon) return if $h_inner; # handle AutoInactiveDestroy and InactiveDestroy $h->{InactiveDestroy} = 1 if $h->{AutoInactiveDestroy} and $$ != $h->{dbi_pp_pid}; $h->{Active} = 0 if $h->{InactiveDestroy}; # copy err/errstr/state up to driver so $DBI::err etc still work if ($h->{err} and my $drh = $h->{Driver}) { $drh->{$_} = $h->{$_} for ('err','errstr','state'); } } if $method_name eq 'DESTROY'; push @pre_call_frag, q{ return $h->{$_[0]} if exists $h->{$_[0]}; } if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ? push @pre_call_frag, "return;" if IMA_STUB & $bitmask; push @pre_call_frag, q{ $method_name = pop @_; } if IMA_FUNC_REDIRECT & $bitmask; push @pre_call_frag, q{ my $parent_dbh = $h->{Database}; } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask; push @pre_call_frag, q{ warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems $parent_dbh->{Statement} = $h->{Statement} if $parent_dbh; } if IMA_COPY_UP_STMT & $bitmask; push @pre_call_frag, q{ $h->{Executed} = 1; $parent_dbh->{Executed} = 1 if $parent_dbh; } if IMA_EXECUTE & $bitmask; push @pre_call_frag, q{ %{ $h->{CachedKids} } = () if $h->{CachedKids}; } if IMA_CLEAR_CACHED_KIDS & $bitmask; if (IMA_KEEP_ERR & $bitmask) { push @pre_call_frag, q{ my $keep_error = 1; }; } else { my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask) ? q{= $h->{dbi_pp_parent}->{dbi_pp_call_depth} } : ""; push @pre_call_frag, qq{ my \$keep_error $ke_init; }; my $keep_error_code = q{ #warn "$method_name cleared err"; $h->{err} = $DBI::err = undef; $h->{errstr} = $DBI::errstr = undef; $h->{state} = $DBI::state = ''; }; $keep_error_code = q{ printf $DBI::tfh " !! %s: %s CLEARED by call to }.$method_name.q{ method\n". $h->{err}, $h->{err} if defined $h->{err} && $DBI::dbi_debug & 0xF; }. $keep_error_code if exists $ENV{DBI_TRACE}; push @pre_call_frag, ($ke_init) ? qq{ unless (\$keep_error) { $keep_error_code }} : $keep_error_code unless $method_name eq 'set_err'; } push @pre_call_frag, q{ my $ErrCount = $h->{ErrCount}; }; push @pre_call_frag, q{ if (($DBI::dbi_debug & 0xF) >= 2) { local $^W; my $args = join " ", map { DBI::neat($_) } ($h, @_); printf $DBI::tfh " > $method_name in $imp ($args) [$@]\n"; } } if exists $ENV{DBI_TRACE}; # note use of 'exists' push @pre_call_frag, q{ $h->{'dbi_pp_last_method'} = $method_name; } unless exists $DBI::last_method_except{$method_name}; # --- post method call code fragments --- my @post_call_frag; push @post_call_frag, q{ if (my $trace_level = ($DBI::dbi_debug & 0xF)) { if ($h->{err}) { printf $DBI::tfh " !! ERROR: %s %s\n", $h->{err}, $h->{errstr}; } my $ret = join " ", map { DBI::neat($_) } @ret; my $msg = " < $method_name= $ret"; $msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n"; print $DBI::tfh $msg; } } if exists $ENV{DBI_TRACE}; # note use of exists push @post_call_frag, q{ $h->{Executed} = 0; if ($h->{BegunWork}) { $h->{BegunWork} = 0; $h->{AutoCommit} = 1; } } if IMA_END_WORK & $bitmask; push @post_call_frag, q{ if ( ref $ret[0] and UNIVERSAL::isa($ret[0], 'DBI::_::common') and defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} ) ) { # copy up info/warn to drh so PrintWarn on connect is triggered $h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state}) } } if IMA_IS_FACTORY & $bitmask; push @post_call_frag, q{ $keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount; $DBI::err = $h->{err}; $DBI::errstr = $h->{errstr}; $DBI::state = $h->{state}; if ( !$keep_error && defined(my $err = $h->{err}) && ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth}) ) { my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError HandleError)}; my $msg; if ($err && ($pe || $re || $he) # error or (!$err && length($err) && $pw) # warning ) { my $last = ($DBI::last_method_except{$method_name}) ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name; my $errstr = $h->{errstr} || $DBI::errstr || $err || ''; my $msg = sprintf "%s %s %s: %s", $imp, $last, ($err eq "0") ? "warning" : "failed", $errstr; if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) { $msg .= ' [for Statement "' . $Statement; if (my $ParamValues = $h->FETCH('ParamValues')) { $msg .= '" with ParamValues: '; $msg .= DBI::_concat_hash_sorted($ParamValues, "=", ", ", 1, undef); $msg .= "]"; } else { $msg .= '"]'; } } if ($err eq "0") { # is 'warning' (not info) carp $msg if $pw; } else { my $do_croak = 1; if (my $subsub = $h->{'HandleError'}) { $do_croak = 0 if &$subsub($msg,$h,$ret[0]); } if ($do_croak) { printf $DBI::tfh " $method_name has failed ($h->{PrintError},$h->{RaiseError})\n" if ($DBI::dbi_debug & 0xF) >= 4; carp $msg if $pe; die $msg if $h->{RaiseError}; } } } } }; my $method_code = q[ sub { my $h = shift; my $h_inner = tied(%$h); $h = $h_inner if $h_inner; my $imp; if ($method_name eq 'DESTROY') { # during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value" # implying that tied() above lied to us, so we need to use eval local $@; # protect $@ $imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction } else { $imp = $h->{"ImplementorClass"} or do { warn "Can't call $method_name method on handle $h after take_imp_data()\n" if not exists $h->{Active}; return; # or, more likely, global destruction }; } ] . join("\n", '', @pre_call_frag, '') . q[ my $call_depth = $h->{'dbi_pp_call_depth'} + 1; local ($h->{'dbi_pp_call_depth'}) = $call_depth; my @ret; my $sub = $imp->can($method_name); if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) { push @_, $method_name; } if ($sub) { (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_)); } else { # XXX could try explicit fallback to $imp->can('AUTOLOAD') etc # which would then let Multiplex pass PurePerl tests, but some # hook into install_method may be better. croak "Can't locate DBI object method \"$method_name\" via package \"$imp\"" if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[; } ] . join("\n", '', @post_call_frag, '') . q[ return (wantarray) ? @ret : $ret[0]; } ]; no strict qw(refs); my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code}; warn "$@\n$method_code\n" if $@; die "$@\n$method_code\n" if $@; *$method = $code_ref; if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool my $l=0; # show line-numbered code for method warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code); } } sub _new_handle { my ($class, $parent, $attr, $imp_data, $imp_class) = @_; DBI->trace_msg(" New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n") if $DBI::dbi_debug >= 3; $attr->{ImplementorClass} = $imp_class or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given"); # This is how we create a DBI style Object: # %outer gets tied to %$attr (which becomes the 'inner' handle) my (%outer, $i, $h); $i = tie %outer, $class, $attr; # ref to inner hash (for driver) $h = bless \%outer, $class; # ref to outer hash (for application) # The above tie and bless may migrate down into _setup_handle()... # Now add magic so DBI method dispatch works DBI::_setup_handle($h, $imp_class, $parent, $imp_data); return $h unless wantarray; return ($h, $i); } sub _setup_handle { my($h, $imp_class, $parent, $imp_data) = @_; my $h_inner = tied(%$h) || $h; if (($DBI::dbi_debug & 0xF) >= 4) { local $^W; print $DBI::tfh " _setup_handle(@_)\n"; } $h_inner->{"imp_data"} = $imp_data; $h_inner->{"ImplementorClass"} = $imp_class; $h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0; # XXX not maintained if ($parent) { foreach (qw( RaiseError PrintError PrintWarn HandleError HandleSetErr Warn LongTruncOk ChopBlanks AutoCommit ReadOnly ShowErrorStatement FetchHashKeyName LongReadLen CompatMode )) { $h_inner->{$_} = $parent->{$_} if exists $parent->{$_} && !exists $h_inner->{$_}; } if (ref($parent) =~ /::db$/) { $h_inner->{Database} = $parent; $parent->{Statement} = $h_inner->{Statement}; $h_inner->{NUM_OF_PARAMS} = 0; } elsif (ref($parent) =~ /::dr$/){ $h_inner->{Driver} = $parent; } $h_inner->{dbi_pp_parent} = $parent; # add to the parent's ChildHandles if ($HAS_WEAKEN) { my $handles = $parent->{ChildHandles} ||= []; push @$handles, $h; Scalar::Util::weaken($handles->[-1]); # purge destroyed handles occasionally if (@$handles % 120 == 0) { @$handles = grep { defined } @$handles; Scalar::Util::weaken($_) for @$handles; # re-weaken after grep } } } else { # setting up a driver handle $h_inner->{Warn} = 1; $h_inner->{PrintWarn} = $^W; $h_inner->{AutoCommit} = 1; $h_inner->{TraceLevel} = 0; $h_inner->{CompatMode} = (1==0); $h_inner->{FetchHashKeyName} ||= 'NAME'; $h_inner->{LongReadLen} ||= 80; $h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN; $h_inner->{Type} ||= 'dr'; } $h_inner->{"dbi_pp_call_depth"} = 0; $h_inner->{"dbi_pp_pid"} = $$; $h_inner->{ErrCount} = 0; $h_inner->{Active} = 1; } sub constant { warn "constant(@_) called unexpectedly"; return undef; } sub trace { my ($h, $level, $file) = @_; $level = $h->parse_trace_flags($level) if defined $level and !DBI::looks_like_number($level); my $old_level = $DBI::dbi_debug; _set_trace_file($file) if $level; if (defined $level) { $DBI::dbi_debug = $level; print $DBI::tfh " DBI $DBI::VERSION (PurePerl) " . "dispatch trace level set to $DBI::dbi_debug\n" if $DBI::dbi_debug & 0xF; } _set_trace_file($file) if !$level; return $old_level; } sub _set_trace_file { my ($file) = @_; # # DAA add support for filehandle inputs # # DAA required to avoid closing a prior fh trace() $DBI::tfh = undef unless $DBI::tfh_needs_close; if (ref $file eq 'GLOB') { $DBI::tfh = $file; select((select($DBI::tfh), $| = 1)[0]); $DBI::tfh_needs_close = 0; return 1; } if ($file && ref \$file eq 'GLOB') { $DBI::tfh = *{$file}{IO}; select((select($DBI::tfh), $| = 1)[0]); $DBI::tfh_needs_close = 0; return 1; } $DBI::tfh_needs_close = 1; if (!$file || $file eq 'STDERR') { open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!"; } elsif ($file eq 'STDOUT') { open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!"; } else { open $DBI::tfh, ">>$file" or carp "Can't open $file: $!"; } select((select($DBI::tfh), $| = 1)[0]); return 1; } sub _get_imp_data { shift->{"imp_data"}; } sub _svdump { } sub dump_handle { my ($h,$msg,$level) = @_; $msg||="dump_handle $h"; print $DBI::tfh "$msg:\n"; for my $attrib (sort keys %$h) { print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n"; } } sub _handles { my $h = shift; my $h_inner = tied %$h; if ($h_inner) { # this is okay return $h unless wantarray; return ($h, $h_inner); } # XXX this isn't okay... we have an inner handle but # currently have no way to get at its outer handle, # so we just warn and return the inner one for both... Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl"); return $h unless wantarray; return ($h,$h); } sub hash { my ($key, $type) = @_; my ($hash); if (!$type) { $hash = 0; # XXX The C version uses the "char" type, which could be either # signed or unsigned. I use signed be