view release on metacpan or  search on metacpan

lib/DBIx/Web.pm  view on Meta::CPAN

			&& !$ENV{MOD_PERL};
	my ($i, @a) =(1);
	while (@a =caller($i)) {
		# $_[0] && $_[0]->logRec('ineval',$i,$a[0],$a[1],$a[2],$a[3]);
		return(0) if $a[0] =~/^(?:PerlEx::|Apache::Perl|Apache::Registry|Apache::ROOT|ModPerl::ROOT|ModPerl::RegistryCoker)/i;
		return(1) if $a[3] eq '(eval)';
		$i +=1;
	}
}


sub die {
 &{$_[0]->{-die}}($_[0]->{-ermu} 
	.(($#_ <2) && ($_[1] !~/[\r\n]$/)
		? ($_[1] .$_[0]->{-ermd})
		: join('',@_[1..$#_])))
}


sub warn {
 &{$_[0]->{-warn}}(@_[1..$#_])
}


sub diags {	# Health and Inspector
 my ($s, $o) =@_;	# (-html,all,perl,env,cgi,cgiparam)
 $o ='-' if !$o;
 $CACHE->{-new} =1	if !defined($CACHE->{-new});
 $CACHE->{-destroy} =0	if !defined($CACHE->{-destroy});
 my $r ='***HEALTH: ';
 my ($rs, $rc, $rp) =(undef, 0, '');
 $rs =sub{	if (!$_[0] ||!ref($_[0]) ||(ref($_[0]) eq 'CODE')) {}
		elsif (ref($_[0]) && ($_[0]=~/hash/i)) {
			if (($_[0] eq $s) && $_[1]) {
				$rc +=1; $rp .=$_[1] .';';
				return(0)
			}
			foreach my $k (keys %{$_[0]}) {
				&$rs($_[0]->{$k}, ($_[1] || '') ."{$k}") if ref($_[0]->{$k})
			}
		}
		elsif (ref($_[0]) && ($_[0]=~/array/i)) {
			for(my $i=0; $i <=$#{$_[0]}; $i++) {
				&$rs($_[0]->[$i], ($_[1] || '') ."[$i]") if ref($_[0]->[$i])
			}
		}};
 &$rs($s, '');
 $r .=($CACHE->{-new} ? 'new=' .$CACHE->{-new} .' ' : '')
	.($CACHE->{-destroy} ? 'DESTROY=' .$CACHE->{-destroy} .' ' : '')
	.($rc ? 'self recurse=' .$rp .' ' : '')
	.getlogin();

 $r .="\n===Perl: \$^X=$^X; \$]=$]; \@INC=" .join(', ', map{"'$_'"} @INC) .'; getlogin=' .getlogin()
	if ($o =~/\b(?:perl|all)\b/i);
 $r .="\n===\%ENV: " .join(', ', map {"$_=" .(defined($ENV{$_}) ? "'" .$ENV{$_} ."'" : 'undef')
		} qw(SERVER_SOFTWARE SERVER_PROTOCOL DOCUMENT_ROOT GATEWAY_INTERFACE MOD_PERL PERLXS PERL_SEND_HEADER REMOTE_USER TMP TEMP SCRIPT_NAME PATH_INFO PATH_TRANSLATED REQUEST_METHOD REQUEST_URI QUERY_STRING REDIRECT_QUERY_STRING CONTENT_TYPE CONTENT_LENG...
	if ($o =~/\b(?:env|all)\b/i);
 $r .="\n===CGI: " .join(', '
	,(map {	my $v =eval("\$CGI::$_");
		("\$$_=" .(defined($v) ? "'$v'" : 'undef'))
		} qw (VERSION TAINTED MOD_PERL PERLEX XHTML NOSTICKY NPH PRIVATE_TEMPFILES TABINDEX CLOSE_UPLOAD_FILES POST_MAX HEADERS_ONCE USE_PARAM_SEMICOLONS))
	,(map {	my $v =$s->url(!$_ ? () : ($_=>1));
		(($_||'%url') .'=' .(defined($v) ? "'$v'" : 'undef'))
		} '', qw(-absolute -relative -base))
	,'-self_url=' .($s->cgi->self_url()||'')
	)
	if $s->{-cgi} && ($o =~/\b(?:cgi|all)\b/i);
 $r .="\n===CGI param: " .join(', '
	,map {("$_=" .(defined($s->cgi->param($_)) ? "'" .$s->cgi->param($_) ."'" : 'undef'))
		} $s->cgi->param
	)
	if $s->{-cgi} && ($o =~/\b(?:cgiparam|all)\b/i);
$o =~/\b(?:html)\b/i
? join("<br /n>", split /[\r\n]/, $s->htmlEscape($r))
: $r
}


sub cgibus {	# (self, set) -> is cgi-bus mode?
 return($_[0]->{-cgibus}) if !ref($_[0]->{-cgibus});
 local $_;
 $_ =&{$_[0]->{-cgibus}}($_[0]
	, $_ =$_[0]->{-pcmd} && ($_[0]->{-pcmd}->{-table} || $_[0]->{-pcmd}->{-form})
	  || $_[0]->cgi->param('_table') || $_[0]->cgi->param('_form') || $_[0]->cgi->param('_key')
	  || 'default'
	, $_[1]);
 $_[0]->set(-cgibus=>$_) if $_[1];
 $_
}


sub start {	# start session
 my $s =shift;
 my %o =@_;
 if (!$s->{-c}->{-startinit}) {
	$CACHE->{$s}	={};
	$s->{-c}	={};
 }
 delete $s->{-c}->{-startinit};
 $s->{-fetched} =0;
 $s->{-limited} =0;
 $s->{-affected}=0;
 $s->{-var}->{'_handle'}->destroy if $s->{-var} && $s->{-var}->{'_handle'};
 $s->w32IISdpsn()	if (($ENV{SERVER_SOFTWARE}||'') =~/IIS/)
			&& ((defined($s->{-w32IISdpsn})
				? $s->{-w32IISdpsn} ||0
				: 2) >1)
			&& !$s->cgi->param('_qftwhere');
 unless ((($ENV{SERVER_SOFTWARE}||'') =~/IIS/)
	&& $s->cgi->param('_qftwhere')) {
	 $s->varLoad(!$s->{-serial} ? 0 : $s->{-serial} >2 ? LOCK_EX : $s->{-serial} >1 ? LOCK_SH : $s->{-serial} >0 ? LOCK_SH : 0);
	 $s->logOpen() if $s->{-log} && !ref($s->{-log});
	 $s->{-log}->lock(0) if ref($s->{-log});
 }
 $s->set(@_);
 $s
}


sub end {	# end session
 my $s =shift;

lib/DBIx/Web.pm  view on Meta::CPAN

sub utf8enc {	# Encode to UTF8, see also cptran()
	my $r =$_[1];
	if (($] >=5.008) && eval("use Encode; 1")) {
		# return($r) if Encode::is_utf8($r);
		my $cp =eval('!${^ENCODING}') && $_[0]->charpage();
		eval("use encoding '$cp', STDIN=>undef, STDOUT=>undef") if $cp;
		$r =Encode::encode_utf8($r);
		eval('no encoding') if $cp;
		return($r);
	}
	my $t =$LNG->{'utf8enc_' .($_[0]->{-lang}||'')};
	return($r) if !$t;
	&$t($r);
	$r;
}


sub utf8dec {	# Decode from UTF8, see also cptran()
	my $r =$_[1];
	if (($] >=5.008) && eval("use Encode; 1")) {
		my $cp =eval('!${^ENCODING}') && $_[0]->charpage();
		eval("use encoding '$cp', STDIN=>undef, STDOUT=>undef") if $cp;
		$r =Encode::decode_utf8($r,0);
		eval('no encoding')		if $cp;
		$r =Encode::encode($cp,$r,0)	if $cp;
		return($r);
	}
	my $t =$LNG->{'utf8dec_' .($_[0]->{-lang}||'')};
	return($r) if !$t;
	&$t($r);
	$r;
}



#########################################################
# Misc Utility methods
#########################################################


sub cgi {       # CGI object
 return($_[0]->{-cgi}) if $_[0]->{-cgi};
 if (!eval("use CGI (); 1") ||!eval("use CGI (); 1")) {
	my $e =$@ ||'undef';
	$_[0]->logRec('error',"use CGI -> $e");
	# eval('use CGI::Carp'); CGI::Carp::croak("use CGI -> $e\n");
	&{$_[0]->{-die}}("use CGI -> $e\n");
 }
 no warnings;	# consider also $CGI::Q - default CGI object - due to bugs
 $_[0]->{-cgi} =$CGI::Q =eval('local $^W =0; CGI->new()');
 if (!$_[0]->{-cgi}) {
	my $e =$@ ||'undef';
	$_[0]->logRec('error',"CGI::new() -> $e");
	# eval('use CGI::Carp'); CGI::Carp::croak("CGI::new() -> $e\n");
	&{$_[0]->{-die}}("CGI::new() -> $e\n");
 }
 if ($_[0]->{-cgi}->{'.cgi_error'}) {
	$_[0]->{-c}->{'.cgi_error'} =$_[0]->{-cgi}->{'.cgi_error'};
	$_[0]->logRec('error','CGI::new() -> ' .$_[0]->{-cgi}->{'.cgi_error'})
 }
 $CGI::XHTML =0;
 $CGI::USE_PARAM_SEMICOLONS =$HS eq ';' ? 1 : 0;
 if ((($ENV{SERVER_SOFTWARE}||'') =~/IIS/i)
 ||  ($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER})) {
	$CGI::NPH =1
 }
 if ($ENV{PERLXS}) {
 }
 if (($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/) {
 }
 $_[0]->{-cgi}
}


sub url {	# CGI script URL
 if ($#_ >0) {
	local $^W =0;
	my $v =($_[0]->{-cgi}||$_[0]->cgi)->url(@_[1..$#_]);
	if ($v) {}
	elsif (!($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {}
	elsif (($#_ >2) ||(($#_ ==2) && !$_[2])) {}
	elsif ($_[1] eq '-relative') {
		$v =$ENV{SCRIPT_NAME};
		$v =$1 if $v =~/[\\\/]([^\\\/]+)$/;
	}
	elsif ($_[1] eq '-absolute') {
		$v =$ENV{SCRIPT_NAME}
	}
	return($v)
 }
 return($_[0]->{-c}->{-url})
	if $_[0]->{-c}->{-url};
 local $^W =0;
 $_[0]->{-c}->{-url} =$_[0]->cgi->url();
 if ($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/)) {
	$_[0]->{-c}->{-url} .=
		(($_[0]->{-c}->{-url} =~/\/$/) ||($ENV{SCRIPT_NAME} =~/^\//) ? '' : '/')
		.$ENV{SCRIPT_NAME}
		if ($_[0]->{-c}->{-url} !~/\w\/\w/) && $ENV{SCRIPT_NAME};
 }
 $_[0]->{-c}->{-url}
}


sub dbi {       # DBI connection object
 return ($_[0]->{-dbi}) if $_[0]->{-dbi};
 $_[0]->{-dbidsn} =ref($_[0]->{-dbiarg}) ? $_[0]->{-dbiarg}->[0] : $_[0]->{-dbiarg};
 $_[0]->{-dbi} =$_[0]->dbiConnect()
		|| &{$_[0]->{-die}}($_[0]->lng(0,'dbi') .": DBI::conect() -> failure\n");
 $_[0]->{-dbi}->{AutoCommit} =$_[0]->{-autocommit};
 if (!$_[0]->{-dbistart}) {
 }
 elsif (ref($_[0]->{-dbistart}) eq 'CODE') {
	&{$_[0]->{-dbistart}}(@_)
 }
 elsif (ref($_[0]->{-dbistart}) eq 'ARRAY') {
	foreach my $v (@{$_[0]->{-dbistart}}) {
		$_[0]->logRec('dbi',$v);
		eval{$_[0]->{-dbi}->do($v)};
		next if !$_[0]->{-dbi}->err;
		$_[0]->logRec($_[0]->lng(0,'Error'), $_[0]->{-dbi}->errstr);