DBIx-Web
4 results

 view release on metacpan or  search on metacpan

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

#########################################################


sub cgiRun {	# Execute CGI query
 my $s =$_[0];
 my $r;
 local($s->{-pcmd}, $s->{-pdta}, $s->{-pout});
		# Automatic upgrade
 if ($s->{-setup} && !$ARGV[0]
 && (!$s->{-diero} ||($s->{-diero} ne 'e'))) {
 	my $ds =(stat(main::DATA))[9] ||0;
	my $dv =($ds && (stat($s->varFile()))[9])||0;
	$ARGV[0] ='-setup' if $ds >$dv;
 }
		# Command line service options
 if ($ARGV[0] && ($ARGV[0] =~/^-/)) {
	$s->start();
	print "Content-type: text/plain\n\n";
	print "'$0' service operation: '" .$ARGV[0] ."'...\n";
	if ($ARGV[0] eq '-reindex') {
		$r =$s->recReindex(1);
	}
	elsif ($ARGV[0] eq '-setup') {
		$r =$s->setup();
		$s->varStore();
	}
	elsif ($ARGV[0] eq '-call') {
		$r =$ARGV[1];
		$r =$s->$r(@ARGV[2..$#ARGV]);
	}
	# print "'$0' service operation: '" .$ARGV[0] ."'->$r\n";
	$s->end();
	return($s)
 }
		# Error display handler
 $s->{-ermu} ='/*User*/ ';
 $s->{-ermd} =' /*Trace*/ ';
 local $SELF =$s;
 my $he =sub{
	my $s =$SELF;
	if (!$s 
	||$s->ineval()) {
		if ($s && $s->{-diero} && ($s->{-diero} eq 'o')) {
			CORE::die(@_)
		}
		return
	}
	delete $s->{-pcmd}->{-xml} if $s->{-pcmd};
	my $e =join('',@_); chomp($e);
	my $ermu =$s->{-ermu};
	if ($ermu && ($e =~/^\Q$ermu\E(.*)/))	{$e =$1}
	else					{$ermu =undef}
	eval{$s->logRec('Die', $e)} if !$ermu;
	eval{$s->recRollback()};
	$s->{-c}->{-httpheader} =$s->{-c}->{-httpheader} ||"Content-type: text/html\n\n"
		if *fatalsToBrowser{CODE};
	eval{	$s->output($s->htmlStart());
		local $s->{-pcmd}->{-cmd}	='frmErr';
		local $s->{-pcmd}->{-cmg}	='frmHelp';
		local $s->{-pcmd}->{-backc}	=0;
		$s->output($s->htmlHidden(),$s->htmlMenu());
		}
		if !$s->{-c}->{-htmlstart};
	eval{	my $h2;
		my $ermd =$s->{-ermd};
		if ($e =~/\Q$ermd\E/) {
			$h2 =$`;
			$e  =$';
		}
		elsif ($e =~/[\n\r]/) {
			$h2 =$`;
			$e  =$';
			if ($h2 =~/\s+(?:at\s+)*line\s+\d+\s+at\s+[^\s]+?\s+line\s+\d+\s*$/) {
				$h2 =$`;
				$e  =$& ."\n\r" .$e
			}
			elsif ($h2 =~/\s+at\s+[^\s]+?\s+line\s+\d+$/) {
				$h2 =$`;
				$e  =$& ."\n\r" .$e
			}
		}
		else {
			$h2 =$e;
			$e  ='';
		}
		$e =~s/[\n\r]/<br \/>\n/g;
		$s->output('<span class="ErrorMessage"><hr class="ErrorMessage" />'
		,'<h1 class="ErrorMessage">'
		, htmlEscape($s, lng($s, 0,'Error')), ' '
		, htmlEscape($s, lng($s, 0, ($s->{-pcmd} && $s->{-pcmd}->{-cmd})||'Open'))
		, '@'
		, htmlEscape($s, lng($s, 0, ($s->{-pcmd} && $s->{-pcmd}->{-cmg})||'Start'))
		, "</h1>\n"
		, $h2
		? '<h2 class="ErrorMessage">'
			.$h2
			."</h2>\n"
		: ()
		, $e, "</span>\n");
	     $s->cgiFooter();
	     $s->output("<hr />\n",$s->htmlEnd())};
	eval{$s->end()};
	if ($s->{-diero} && ($s->{-diero} eq 'o')) {
		if ($ermu)	{goto cgiRunEND}
		else		{CORE::die(@_)}
	}};
 if ($s->{-diero}) {
 }
 elsif (1 && ($ENV{MOD_PERL} || (($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {
	local $s->{-diero} ='e';
	$SIG{__DIE__}='DEFAULT';
	# $s->{-serial}	=0 if $s->{-serial};
	my $r =eval{$s->cgiRun(); 1};
	local $CACHE->{-destroy} =0;
	if (!$r) {
		&$he($@);
		$s->DESTROY();
		return(undef);
	}
	else {
		$s->DESTROY();

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

		$s->end();
		return($r)
	}

	my $nxt;			# delegation - substitute object
	foreach my $v (map {$om->{"-$_"}} 
			 'subst', $oa
			, $og =~/rec(New|Read|Del|QBF)/ 
			? ($og, 'recForm') 
			: $og) {
		next if !defined($v) || ref($v);
		last if !$v;
		$on = $nxt =$v;
		last
	}
	$on =$nxt =$s->{-pcmd}->{-form} =$om->{-table}
		if !$nxt
		&& ($og eq 'recNew') && ($oc eq 'f')
		&& !exists($om->{-recNew}) && !exists($om->{-recForm})
		&& !$om->{-field}
		&& $om->{-table} && $s->mdeTable($om->{-table})
		&& !$s->{-table}->{$om->{-table}}->{-ixcnd};
	next if $nxt;
	last;
 }

		# Execute action
 $s->cgibus(1);
 if	(ref(my $e =$om->{"-$oa"}) eq 'CODE') {
	$s->{-pout} =&$e($s, $on, $om, $s->{-pcmd}, $s->{-pdta});
 }
 else	{
	$s->{-pout} =$s->cgiAction($on, $om, $s->{-pcmd}, $s->{-pdta});
 }

		# Reassign form if changed
 $s->{-pcmd}->{-form} =(isa($s->{-pout}, 'HASH') && $s->{-pout}->{-form})
			|| $s->{-pcmd}->{-form} ||$on;

		# Execute external presentation '-cgvXXX'
 foreach my $e (map {$om->{"-cgv$_"}}
		 $oa =~/^rec(.+)/ ? $1 : $oa
		,$og =~/^rec(.+)/ ? $1 : $og, 'Call') {
	next if !defined($e);
	last if !$e;
	last if $oa eq 'frmHelp';
	$_ =$s;
	$r =	  ref($e)
		? &$e($s, $on, $om, $s->{-pcmd}, $s->{-pout})
		: $e =~/\.psp$/i 
		? $s->psEval('-', $e, undef, $on, $om, $s->{-pcmd}, $s->{-pout})
		: do($e);
	$s->end();
	return($r);
 }

		# Execute predefined presentation implementation
 $s->output(
	 $s->htmlStart($s->{-pcmd}->{-form}, $om)	# HTTP/HTML/Form headers
	,$s->htmlHidden($s->{-pcmd}->{-form}, $om)	# common hidden fields
	,$s->htmlMenu($on, $om)				# Menu bar
	);
 $s->cgiForm($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('recFormRWQ');
 $s->cgiList($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('recList');
 $s->cgiHelp($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('frmHelp');
 $s->recCommit();
 $s->cgiFooter();
 $s->output($s->htmlEnd());
 $s->end();
 cgiRunEND:
 $s
}


sub cgiParse {	# Parse CGI call parameters
 my ($s) =@_;
 my $g =$s->cgi;
 my $d =$g->Vars;
 $s->{-pcmd} ={};
 $s->{-pdta} ={};
 $s->{-lng} =$g->http('Accept_language')||'';
 $s->set(-lng =>lc($s->{-lng} =~/^([^ ;,]+)/ ? $1 : $s->{-lng}));
 foreach my $k (keys %$d) {
	next if !defined($d->{$k} || $d->{$k} eq '');
	if($k =~/^_(quname)__S$/) {		# cgiDDLB choise
		$s->{-pcmd}->{"-$1"} =$d->{'_' .$1 .'__L'};
		$s->{-pdta}->{$k} =$d->{$k};
		$d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm';
	}
	elsif($k =~/^(.+)__S$/) {		# cgiDDLB choise
		$s->{-pdta}->{$1} =$d->{$1 .'__L'};
		$s->{-pdta}->{$k} =$d->{$k};
		$d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm';
	}
	elsif($k =~/^(.+)__R$/) {		# cgiDDLB reset
		$s->{-pdta}->{$1} =undef;
		$s->{-pdta}->{$1 .'__S'} =$d->{$k};
		$d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm';
	}
	elsif($k =~/^(.+)__O$/) {		# cgiDDLB open
		$s->{-pdta}->{$k} =$d->{$k};
		$d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm';
	}
	elsif($k =~/^_(new|file)$/) {		# record attribute
		$s->{-pdta}->{"-$k"} =$d->{$k}
	}
	elsif ($k =~/^_(cmd|cmg|frmCall|frmName\d*|frmLso|frmLsc|frmHelp|recNew|recRead|recPrint|recXML|recHist|recEdit|recIns|recUpd|recDel|recForm|recList|recQBF|submit.*|app.*|form|key|wikn|wikq|proto|urm|qjoin|qkey|qwhere|qurole|quname|qftext|qversion|v...
		my ($c, $v) =($1, $d->{$k});	# command
		$v =$1	if ($k !~/^_(key|proto|qkey|qftext)/i)
			&& ($v =~/^\s*(.+?)\s*$/);
		if ($k =~/^(.+)\.[xXyY]$/) {
			$g->param($1, 1);
			$g->delete($k);
			$v=1;
		}
		if ($c =~/^(?:rec|frmCall|frmHelp|submit)/i) {
			$s->{-pcmd}->{-cmd} =$c
		}
		elsif (($c eq 'frmLso') && ($v =~/,/)) {
			$s->{-pcmd}->{"-$c"}=[split /\s*,\s*/, $v];
		}

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

 my ($s,$on,$om)=@_;	# (object name, object meta)
 $on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||'default'
	if !$on;
 my $cs	= $s->{-c}->{-htmlclass}
	= $s->{-pcmd}->{-xml}
	? undef
	: ref($s->{-htmlstart}) && $s->{-htmlstart}->{-class}
	? $s->{-htmlstart}->{-class}
	: $s->cgiHook('recOp')
	? 'Form' .($on ? ' ' .$on : '')
	: $s->cgiHook('recFormQ')
	? 'Form' .($on ? ' ' .$on : '') .' QBF' .($on ? ' ' .$on .'__QBF' : '')
	: $s->cgiHook('frmHelp')
	? 'Form Help' .($on ? ' ' .$on .'__Help' : '')
	: 'Form' .($on ? ' ' .$on : '') .' List' .($on ? ' ' .$on .'__List' : '');
 my $r	=join(""
	, $s->{-c}->{-httpheader}
	? ()
	: do{$s->{-c}->{-httpheader} =$s->cgi->header(
		-charset => $s->charset()
	#	, -expires => 'now'
		, uc($ENV{REQUEST_METHOD}||'') ne 'POST' ? (-expires=>'now') : ()
		, ref($s->{-httpheader}) 
		? %{$s->{-httpheader}} 
		: ()
		, $s->{-pcmd}->{-xml}
		? (-type => 'text/xml')
		: ()
		)}
	, $s->{-c}->{-htmlstart}  =
		  $s->{-pcmd}->{-xml}
		? (ref($s->{-xmlstart})
			? $s->xmlsTag($s->{-xmlstart})
			: ($s->{-xmlstart} 
			||('<?xml version="1.0"'
				.(!$s->{-charset}
				 ? ''
				 : ' encoding="' .$s->charset() .'"')
			  .' ?>'))
		  .($s->{-pcmd}->{-style}
		   ? '<?xml:stylesheet href="' .$s->{-pcmd}->{-style} .'" type="text/css" ?>'
		   : '')
		  )
		: $s->cgi->start_html(
			 -head	=> '<meta http-equiv="Content-Type" content="text/html; charset=' .$s->charset() .'">'
				.($s->{-pcmd}->{-refresh} 
					? '<meta http-equiv="refresh" content=' .$s->{-pcmd}->{-refresh} .'>' 
					: '')
			,-lang	=> $s->lang(0,'-lang')
			,-encoding => $s->charset()
			,-style	=> {-code=>''
				.".Body {font-size: 70%; font-family: Verdana, Helvetica, Arial, sans-serif; }\n"
				.".Input {font-size: 100%; font-family: Verdana, Helvetica, Arial, sans-serif; }\n"
				.".Form {margin-top:0px; }\n"
				."td.Form {border-style: none; border-width: 0px; padding: 0px;}\n"
				."th.Form {border-style: none; border-width: 0px; padding: 0px;}\n"
				."table.ListTable {border-collapse: collapse; }\n"
				."th.ListTable {border-style: inset; border-color: buttonface; border-width: 0px; border-bottom-width: 1px; }\n"
				."td.ListTable {border-style: inset; border-color: buttonface; border-width: 0px; border-bottom-width: 1px; padding: 0px; padding-left: 2px; padding-right: 1px; padding-top: 2px;}\n"
				.".ListTableFocus {background-color: buttonface;}\n"
				#.".MenuArea {background-color: navy; color: white;}\n"
				.".MenuButton {background-color: buttonface; color: black; text-decoration:none; font-size: 7pt}\n"
				.".MenuInput {font-size: 8pt}\n"
				.".htmlMQHsel {text-decoration: none; font-weight: bolder; border-style: inset;}\n"
				}
			,-title	=> 
				(do{	my $v =($s->{-pcmd} && $s->{-pcmd}->{-cmd} ||'') eq 'frmHelp'
						? $s->lng(0,'frmHelp')
						: (eval{$om && $s->lnglbl($om)});
					$v ? $v .' - ' : ''})
				.($s->{-title} ||$s->cgi->server_name())
			,-class	=> "Body $cs"
			,$s->{-pcmd}->{-frame}
			? (-target=>$s->{-pcmd}->{-frame})
			: $s->cgiHook('recFormRWQ') && $s->{-pcmd}->{-edit}
			? (-target=>'_blank')
			: (-target=>'_self')
			,ref($s->{-htmlstart}) 
			? %{$s->{-htmlstart}}
			: ()
			,$s->{-pcmd}->{-style}
			? (-style=>{'src'=>$s->{-pcmd}->{-style}})
			: ())
	, "\n"
	, $s->{-pcmd}->{-xml}
		? $s->xmlsTag($s->{-pcmd}->{-form}||'default'
			, (map { defined($s->{-pcmd}->{$_}) && ($s->{-pcmd}->{$_} ne '')
				? ((substr($_,0,1) eq '-' ? substr($_,1) : $_)
				 ,$s->{-pcmd}->{$_})
				: ()
				} sort keys %{$s->{-pcmd}})
			, 'xmlns'=>$s->url
			, '0')
		: $s->cgi->start_multipart_form(-method=>($s->{-pcmd}->{-refresh} ? 'get' : 'post')
			,-class	=> "$cs"
			,-action=> $s->url
			,-target=> '_self'
			,-name=>'DBIx_Web'
			# !!! 'DBIx_Web.' or 'forms[0].' syntax inflexible
			)
 ) ."\n";
 eval{warningsToBrowser(1)} if *warningsToBrowser{CODE};
 $r;
}


sub htmlEnd {	# End of HTML/HTTP output
 my ($s) =@_;
 if ($s->{-pcmd}->{-xml}) {		
	return("\n</" .$s->xmlTagEscape($s->{-pcmd}->{-form}||'default') .">\n")
 }
 else {
	return($s->cgi->endform()
	,"\n"
	,$s->htmlOnLoadW(
		(!$s->{-c}->{-jswload}
		|| !(grep {($_=~/\.target/) && ($_=~/'BASE'/)} @{$s->{-c}->{-jswload}})
		? "{var e=document.getElementsByTagName('BASE'); if(e && e[0] && (e[0].target=='_self')){e[0].target=(self.name=='BOTTOM' ? 'TOP1' : self.name=='TOP' ? 'BOTTOM'"
			.($s->{-pcmd}->{-frame}
				? " : self.name=='" .$s->{-pcmd}->{-frame} ."' ? 'TOP1'"
				 ." : self.name!='" .$s->{-pcmd}->{-frame} ."' ? '" .$s->{-pcmd}->{-frame} ."'"
				: '')
			." : e[0].target)}}"
		: ())
		,($s->{-pcmd}->{-search} && $s->{-c}->{-search}
		? ("{window.document.open('" 
			.($s->{-c}->{-search} =~/^\?/
			? $s->url() .$s->{-c}->{-search}
			: $s->{-c}->{-search}) ."','_search','',true)}")
		: ())
		)
	,$s->cgi->end_html())
 }
}


sub htmlOnLoad {# OnLoad event JavaScript store
	$_[0]->{-c}->{-jswload} =[] if !$_[0]->{-c}->{-jswload};
	push @{$_[0]->{-c}->{-jswload}}, @_[1..$#_];
	''
}


sub htmlOnLoadW {# OnLoad event JavaScript write
 $_[0]->htmlOnLoad(@_[1..$#_]) if $#_;
 return() if !$_[0]->{-c}->{-jswload};
 my $v ="<script for=\"window\" event=\"onload\">\n"
	.join("\n", @{$_[0]->{-c}->{-jswload}})
	."\n</script>\n";
 delete $_[0]->{-c}->{-jswload};
 $v
}


sub htmlHidden {# Common hidden fields
 my ($s, $on, $om) =@_;
 return('') if $s->{-pcmd}->{-xml} ||$s->{-pcmd}->{-print};
 $on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||''
	if !$on;
 join("\n"
	,'<input type="hidden" name="_form" value="' .$s->htmlEscape($on) .'" />'
	,'<input type="hidden" name="_cmd"  value="" />'
	,'<input type="hidden" name="_cmg"  value="' .$s->htmlEscape($s->{-pcmd}->{-cmg}) .'" />'
	,(map { !defined($s->{-pcmd}->{"-$_"})
			|| (($s->{-pcmd}->{"-$_"} eq '') 
				&& ($_ !~/^(?:qkey|qwhere|qurole)$/))
		? ()
		: ('<input type="hidden" name="_' .$_ .'" value="'
		  .$s->htmlEscape(!defined($s->{-pcmd}->{"-$_"})
			? ''
			: ref($s->{-pcmd}->{"-$_"})
			? strdata($s, $s->{-pcmd}->{"-$_"})
			: $s->{-pcmd}->{"-$_"})
		  .'" />')
		} qw(edit backc key style frame)
		,($s->{-pcmd}->{-cmg} ne 'recQBF'
		? qw(qkey qjoin qwhere qurole quname qversion qorder qkeyord qlimit qdisplay)
		: qw(qlist))
		)
	) ."\n"
}


sub htmlMenu {	# Screen menu bar
 my ($s,$on,$om) =@_;
 return('') if $s->{-pcmd}->{-xml} ||$s->{-pcmd}->{-print};
 $on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||''
	if !$on;
 $om =$on && $s->{-form}->{$on}||$s->mdeTable($on) if !$om;
 my $ot=$om && $om->{-table} && $s->mdeTable($om->{-table}) || $om;
 my $c =$s->{-pcmd};
 my $a =$c->{-cmd} ||'';
 my $g =$c->{-cmg} ||'';
 my $e =$c->{-edit};
 my $d =$s->{-pdta};
 my $n =$d->{-new} ||($c->{-cmg} eq 'recNew');
 my $cs=join(' '
	,$s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) : ()
	,'MenuArea');
 local $c->{-cmdt} =$ot || $om;	# table metadata
 local $c->{-cmdf} =$om || $ot;	# form  metadata
 my @r =();
 if	($s->{-logo}) {			# Logotype
	push @r, htmlMB($s, 'logo');
 }
 elsif	($s->{-icons}) {		# Home
	push @r, htmlMB($s, $s->{-c}->{-search}	? 'schpane' : 'home');
 }
 if	(1) {				# 'back' js button
	push @r, htmlMB($s, 'back'
		, $g ne 'recList'
		? $s->urlCmd('',-form=>$on, -cmd=>'recList', $c->{-frame} ? (-frame=>$c->{-frame}) : ())
		: $s->urlCmd('',$c->{-frame} ? (-frame=>$c->{-frame}) : ())
		, ($c->{-backc}||1));
 }
 if	($s->uguest()
	&& $s->{-login}) {		# Login
	push @r,htmlMB($s, 'login', $s->urlAuth());
 }
 if	($g eq 'recList') {		# View menu items
	local @{$s}{-menuchs, -menuchs1} =@{$s}{-menuchs, -menuchs1};
	$s->htmlMChs()
		if !$s->{-menuchs};
      # push @r, htmlMB($s, 'recForm');
	push @r, htmlML($s, 'frmName',  $s->{-menuchs}
			, !$c->{-frame} || ($c->{-frame} =~/^(?:TOP|BOTTOM)$/)
				? '-frame=set'
				: ()
			)	if $s->{-menuchs};
	push @r, htmlML($s, 'frmLso'
			, ref($om->{-frmLso}) eq 'CODE'
				? &{$om->{-frmLso}}($s, $on, $om, $c, exists($c->{-frmLso}) ? $c->{-frmLso} ||'' : ())
				: $om->{-frmLso}
			) if $om->{-frmLso};
	push @r, htmlMB($s,  htmlField($s, '_qftext', lng($s,1,'-qftext'), {-asize=>5, -class=>'Input ' .$cs .' MenuInput'}, $s->{-pcmd}->{-qftext}))
							if $s->{-menuchs};
	push @r, htmlML($s, 'frmName1', $s->{-menuchs1})if $s->{-menuchs1};
	local $c->{-frame} =undef;
	push @r, htmlMB($s, 'frmCall',	['', $s->urlOptl(-cmd=>'frmCall')])
							if $s->{-menuchs};
	push @r, htmlMB($s, 'recXML',	['', $s->urlOptl(-cmd=>'frmCall',-xml=>1)]);
	push @r, htmlMB($s, 'recQBF');
	if ($s->uguest) {}
	elsif ($om->{-recNew} || $om->{-recForm}
	|| ($on && (grep {(	!ref($_)
				? $_
				: ref($_) eq 'HASH'
				? $_->{-val}
				: $_->[0]) =~/^\Q$on\E\+/
		} @{$s->{-menuchs1} ||$s->{-menuchs} ||[]})) ) {
		push @r, htmlMB($s, 'recNew')
	}
	elsif (	$om->{-table}
	&&	!$om->{-field}
	&&	$s->{-table}->{$om->{-table}}
	&&	!$s->{-table}->{$om->{-table}}->{-ixcnd}
	&&	do{my $on =$om->{-table};
		grep {(	!ref($_)
				? $_
				: ref($_) eq 'HASH'
				? $_->{-val}
				: $_->[0]) =~/^\Q$on\E\+/
		} @{$s->{-menuchs1} ||$s->{-menuchs} ||[]}} ){
		push @r, htmlMB($s, 'recNew')
	}
 }
 elsif	($g eq 'recQBF') {		# QBF menu items
	push @r, htmlMB($s, 'recForm',	'');
	push @r, htmlMB($s, 'recQBFReset' );
	push @r, htmlMB($s, 'recList',	'');
	push @r, htmlMB($s, 'recXML',	'');
 }
 elsif	($g eq 'recDel') {		# Deleted record menu items
 }
 elsif	($s->cgiHook('recOp')) {	# Record menu items
	my $ea =(!$s->{-rac} ||$s->{-pout}->{-editable}) &&!$s->uguest
			&& ((ref($s->{-pout}->{-editable}) && $s->{-pout}->{-editable}->{-fr}) ||1);
	my @rk =('','_form'=>$_[0]->{-pcmd}->{-form}, '_key'=>strdata($_[0], $_[0]->{-pcmd}->{-key}));
	my $ll =$s->lnghash();
	local	$ll->{'recIns'} = $e && $n
				? [$ll->{'recUpd'}->[0], $ll->{'recIns'}->[1]]
				: $ll->{'recIns'};
	local	$IMG->{'recIns'}= $e && $n
				? $IMG->{'recUpd'}
				: $IMG->{'recIns'};
	push @r, htmlMB($s, 'recRead',	[@rk, '_cmd'=>'recRead'])
					if !$n;
	push @r, htmlMB($s, 'recPrint',	[@rk, '_cmd'=>'recRead', '_print'=>1])
					if !$n && !$e;
	push @r, htmlMB($s, 'recXML',	[@rk, '_cmd'=>'recRead', '_xml'=>1])
					if !$n && !$e;
	push @r, htmlMB($s, 'recHist',	[@rk, '_cmd'=>'recRead', '_hist'=>1])
					if !$n && !$e
					&& ($ot->{-rvcActPtr} ||$s->{-rvcActPtr});
	push @r, htmlMB($s, 'recEdit',	[@rk, '_cmd'=>'recEdit'])

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

						&& (!ref($ea) ||!$ea->{-recDel});
 }
 if ($a ne 'frmHelp') {			# Help button
	push @r, htmlMB($s, 'frmHelp');
	# push @r, htmlMB($s, 'frmHelp', ['','_cmd'=>'frmHelp','_form'=>$_[0]->{-pcmd}->{-form}]);

 }
 delete $c->{-htmlMQH};
 my $mi	='[\'<i>'	.htmlEscape($s,lng($s, 0, $c->{-cmd}))
	.'\'@\''	.htmlEscape($s,lng($s, 0, $c->{-cmg}))
	.'\',  '	.htmlEscape($s, $s->user()) .'</i>]';
 my $mh =htmlEscape($s
		,($a eq 'frmHelp' 
			? $s->lng(0, 'frmHelp')
			: $s->lngcmt($om, $ot))
		 || (($s->{-title} ||$s->cgi->server_name() ||'') .' - ' .($c->{-form} ||'')));
 my $mc =$g ne 'recList'
	? ''
	: join("; "
	, grep {$_
		} 
		  (defined($c->{-qkey})
			? $c->{-qkey}
			: ($om->{-query} && $om->{-query}->{-qkey}))
		? do {	my $kq =$c->{-qkey} ||($om->{-query} && $om->{-query}->{-qkey});
			my $ko =$c->{-qkeyord}
				|| ($c->{-qorder} && (substr($c->{-qorder},0,1) eq '-') && $c->{-qorder})
				|| '-aeq';
			   $ko ={'eq'=>'=','ge'=>'>=','gt'=>'>','le'=>'<=','lt'=>'<'}->{substr($ko,2)}||'=';
			$s->htmlEscape(
				join(', ', map { "$_ $ko " 
						.dsdQuot($s," $ko ",$kq->{$_})
					} sort keys %$kq))
			}
		: ()
		, ($c->{-qkeyord} ? htmlEscape($s, lng($s, 0, '-qkeyord')  .' ' .lng($s, 0, $c->{-qkeyord} =~/^-*[db]/ ? 'desc' : 'asc')) : '')
		, (!$c->{-qwhere} 
				? ''
				: $c->{-qwhere} =~/^(?:\[\[\]\]|\/\*\*\/)+(.*)/
				? htmlEscape($s, $1)
				: htmlEscape($s, $c->{-qwhere}))
		, ($c->{-qjoin}	  ? htmlEscape($s, ($c->{-qjoin} =~/^\s*(?:CROSS|JOIN|INNER|STRAIGHT_JOIN|LEFT|NATURAL|RIGHT|OUTER)\b/i ? '' : (lng($s, 0, '-qjoin') .' ')) .$c->{-qjoin}) : '')
		, ($c->{-qurole}  ? htmlEscape($s, lng($s, 0, '-qurole')   .' ' .$c->{-qurole} .' /*' .$s->mddUrole($om, $c->{-qurole}) .'*/') : '')
		, ($c->{-quname}  ? htmlEscape($s, lng($s, 0, '-quname')   .' ' .$c->{-quname}) : '')
		, ($c->{-qftext}  ? htmlEscape($s, lng($s, 0, '-qftext')   .' ' .$c->{-qftext}) : '')
		, ($c->{-qversion}? htmlEscape($s, lng($s, 0, '-qversion') .' ' .$c->{-qversion}) : '')
		, ($c->{-qorder}  ? htmlEscape($s, lng($s, 0, '-qorder')	  .' ' .($c->{-qorder} !~/^-/ ? $c->{-qorder} : lng($s, 0, $c->{-qorder} =~/^-[db]/ ? 'desc' : 'asc'))) : '')
	);
    $mc = ($g eq 'recList') && ($om->{-frmLso1C} ||($ot->{-frmLso1C} && !exists($om->{-frmLso1C})))
	? &{$om->{-frmLso1C}||$ot->{-frmLso1C}}($s,$on,$om,$c,$mc)
	: $mc;

 ($s->{-banner}
	? (do{	my $v =ref($s->{-banner}) ? &{$s->{-banner}}($s,$on,$om) : $s->{-banner};
		$v
		? "\n<div class=\"$cs BannerDiv\">$v</div>"
		: ''
		})
	: '')
 .(!$s->{-icons}
 ?  "\n<div class=\"$cs MenuDiv\">" .join("\n", @r, $mi, '<br />', $mh, '<br />', $mc ? ($mc, '<br />') : ()) ."</div>\n\n"
 : ("\n<div class=\"$cs MenuDiv\"><table class=\"$cs\" cellpadding=\"0\"><tr>\n"
	# cellspacing=\"1px\"
	# style=\"position: absolute; top: 0; left: 0;\" # scrolled up
	# <br /><br />
	# scrollHeight
	.join("\n", @r)
	."\n" .'<td class="' .$cs .' MenuCell" valign="middle"><nobr>'
	. $mi .'</nobr></td></tr>'
	."\n" 
	."</table>\n<table class=\"$cs\" cellpadding=0  cellspacing=0 width=100%>"
		# margin-top: 0px; margin-bottom: 0px; padding: 0px
	.'<tr><th class="' .$cs .' MenuHeader" align="left" valign="top" colspan=20>' 
	.$mh .'</th></tr>'
	.(!$mc 	? ''
		: ("\n" .'<tr><td class="' .$cs .' MenuComment" align="left" valign="top" colspan=20>'
			.$mc 
			.'</td></tr>'))
	."\n</table></div>\n"
	.(0 && ($s->user() =~/diags/i) ? $s->diags('-html') : '')
	.(!$c->{-refresh} 
	? $s->htmlOnLoad('{var w=window.document.getElementsByTagName(\'table\')[' .($e ? 1 : 0) .']; if(w){w.focus()}}')
	: '')
	.(0	# scrollTop==0
	? '<script for="window" event="onscroll">{var w=window.document.getElementsByTagName(\'table\')[0]; window.status=document.body.scrollTop; if (!w) {} else if(document.body.scrollTop >(w.height||0)){w.style.position="absolute"; w.style.top=document.b...
	: '')
	."\n"))
}


sub htmlMB {	# CGI menu bar button
		# self, command, url, back|
 my $cs =($_[0]->{-c}->{-htmlclass} ? $_[0]->htmlEscape($_[0]->{-c}->{-htmlclass}) .' ' : '')
	.'MenuArea MenuButton';
 my $td0='<td class="' .$cs .'" valign="middle" style="border-width: thin; border-style: outset;" '; 
 my $tdb=($ENV{HTTP_USER_AGENT}||'') =~/MSIE/ 
	? ' onmousedown="if(window.event.button==1){this.style.borderStyle=&quot;inset&quot;}" onmouseup="this.style.borderStyle=&quot;outset&quot;" onmouseout="this.style.borderStyle=&quot;outset&quot;" onmousein="this.style.cursor=&quot;hand&quot"'
	: ' onmousedown="if(event.which==1){this.style.borderStyle=&quot;inset&quot;}" onmouseup="this.style.borderStyle=&quot;outset&quot;" onmouseout="this.style.borderStyle=&quot;outset&quot;"';
 if (!$_[0]->{-icons}) {
	if ($_[1] =~/^</) {
		$_[1]
	}
	elsif ($_[1] eq 'logo') {
		ref($_[0]->{-logo}) eq 'CODE' 
		? &{$_[0]->{-logo}}(@_) 
		: $_[0]->{-logo}
	}
	elsif ($_[1] eq 'login') {
		$_[1]
	}
	elsif ($_[1] eq 'back') {
		 '<input type="submit" class="Input ' .$cs .'" name="_' .$_[1] .'" '
		.' value="' .htmlEscape($_[0],lng($_[0], 0, $_[1])) .'" '
		.' onclick="{'
		.(!$_[3] ||$_[3] <2
			? 'window.history.back()'
			: 'window.history.go(-' .($_[3]-1) .'); window.history.back()')
		.'; return(false)}" '
		.' title="' .htmlEscape($_[0],lng($_[0], 1, $_[1])) .'" />'
	}
	else {
		 '<input type="submit" class="Input ' .$cs .'" name="_' .$_[1] .'" '
		.' value="' .htmlEscape($_[0],lng($_[0], 0, $_[1])) .'" '
		.' title="' .htmlEscape($_[0],lng($_[0], 1, $_[1])) .'" />'
	}
 }
 elsif ($_[1] =~/^</) {
	$td0 ."><nobr>\n" .$_[1] ."\n</nobr></td>"
 }
 elsif ($_[1] eq 'logo') {
	$_[0]->{-logo}
	? $td0 ."><nobr>\n"
	  .(	  ref($_[0]->{-logo}) eq 'CODE' 
		? &{$_[0]->{-logo}}(@_) 
		: $_[0]->{-logo}) ."\n</nobr></td>"
	: htmlMB($_[0],'home')
 }
 elsif ($_[1] eq 'login') {
	my $jc =' onclick="{window.location.replace(&quot;'
		.htmlEscape($_[0], $_[2])
		.'&quot;); return(false)}" ';
	my $tl =htmlEscape($_[0], lng($_[0], 1, 'login'));
	$td0  .' title="' .$tl .'"'
	.($tdb ? $tdb .$jc : '') ."><nobr>\n"
	.'<a href="' .$_[2] .'" '
	.' title="' .$tl .'" '
	.' class="' .$cs .'" target="_self" '
	.($tdb ? '' : $jc)
	.' ><img src="' .$_[0]->{-icons} .'/' .$IMG->{'login'} 
	.'" border=0  align="bottom" height="22" class="' .$cs .'" />'
	.htmlEscape($_[0], lng($_[0], 0, 'login')) ."</a>\n</nobr></td>"
 }
 elsif ($_[1] eq 'schpane') {
	my $pu =$_[0]->{-c}->{-search};

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

			?('window.history.go(-' .($_[3]-1) 
				.'); window.history.back(); ')
			: 1	# !!! Non MSIE backwarding omission
			?("window.document.open('" .htmlEscape($_[0],$_[2]) ."','_self','',false); ")
			:('window.history.back();' x $_[3])
				)
		.'return(false)}" ';
	my $jo =$jc =~/window\.document\.open/i;
	my $tl =htmlEscape($_[0], (!$jo ? '<-' .($_[3]||1) .'- ' : '') .lng($_[0], 1, 'back'));
	$td0 
	.' title="' .$tl .'"'
	.($tdb ? $tdb .$jc : '') ."><nobr>\n"
	.'<a href="' .($jo ? $_[2] ||$_[0]->url : $_[0]->url) .'" '
	.($tdb ? '' : $jc)
	.' title="' .$tl .'"'
	.' class="' .$cs .'" target="_self"><img src="' .$_[0]->{-icons} .'/' .$IMG->{'back'} .'" border=0 align="bottom" height="22" class="' .$cs .'" '
	.' /></a>' ."\n</nobr></td>"
 }
 else {
	my $hl =defined($_[2]) && !$_[2]
		? undef
		: urlCat($_[0], !$_[2] 
				? ('', '_form'=>$_[0]->{-pcmd}->{-form},'_cmd'=>$_[1]) 
				: ref($_[2]) ? @{$_[2]} : $_[2]);
	my $jc =' onclick="{'
		.(!$hl
		? ''
		: $_[1] =~/^(?:recRead|recPrint|recXML|recHist|recEdit|recNew|frmHelp)$/
		? "if((self.name=='BOTTOM') || (self.name=='TOP') ||document.getElementsByName('_frame').length){window.document.open('"
			.(($_[1] =~/^(?:recNew)$/ && ($hl =~/_proto=/))
			? (do {my $v=$hl; $v =~s/([?&;])_proto=/${1}_key=/; $v})
			: $hl)
			."','_blank','',false); return(false)}\n"
		: '')
		.'window.document.DBIx_Web._cmd.value=&quot;' .$_[1] .'&quot;; window.document.DBIx_Web.submit(); return(false)}" ';
	my $tl =htmlEscape($_[0],lng($_[0], 1, $_[1]));
	$td0 .' title="' .$tl .'"'
	.($tdb ? $tdb .$jc : '') ."><nobr>\n"
	.'<input type="image" name="_' .$_[1] .'" '
	.' src="' .$_[0]->{-icons} .'/' .($IMG->{$_[1]}||'none') .'" '
	.' align="bottom" title="' .$tl .'" class="' .$cs .'" style="cursor: default;"/>'
	.(!$hl
	?('<span class="' .$cs .'" style="cursor: default;"'
	 .' title="' .$tl .'">' .htmlEscape($_[0],lng($_[0], 0, $_[1])) .'</span>')
	 .($tdb ? '' : $jc)
	:('<a tabindex=-1 href="' .$hl .'" class="' .$cs .'" target="_self" '
	 .($tdb ? '' : $jc)
	 .' title="' .$tl .'">'
	 .htmlEscape($_[0],lng($_[0], 0, $_[1]))
	 .'</a>'))
	."\n</nobr></td>"
 }
}


sub htmlML {	# CGI menu bar list
 use locale;	# (self, name, values, ? add values)
 my $cs =join(' '
	,'Input'
	,$_[0]->{-c}->{-htmlclass} ? $_[0]->htmlEscape($_[0]->{-c}->{-htmlclass}) : ()
	,'MenuArea');
 my $i =  $_[1] eq 'frmName'
	? $_[0]->cgi->param('_'  .$_[1]) 
	||$_[0]->{-pcmd}->{'-' .$_[1]}
	||$_[0]->{-pcmd}->{-form} ||''
	: $_[1] eq 'frmLso'
	? (($_[0]->{-pcmd}->{'-' .$_[1]} ||'') eq '-all'
		? ''
		: ($_[0]->{-pcmd}->{'-' .$_[1]} ||''))
	: '';
 my $li =$_[3];
 my $f1 =undef;
 ($_[0]->{-icons}
	? '<td class="' .$cs .' MenuButton" valign="middle" title="'
		.$_[0]->htmlEscape(lng($_[0], 1, $_[1]))
		.'" style="border-width: thin; border-style: outset;" >' 
	: '')
 .do{$cs .=' MenuInput'; ''}
 .'<select name="_' .$_[1]
 .'" class="' .$cs .'" onchange="{'
 .( $_[1] eq 'frmLso'
  ? 'if (_frmLso.value==&quot;recQBF&quot;) {window.document.DBIx_Web._cmd.value=_frmLso.value; _frmLso.value=&quot;' .$_[0]->htmlEscape($i) .'&quot;; window.document.DBIx_Web.submit(); return(true);} else {window.document.DBIx_Web._cmd.value=&quot;f...
  : 1 && ($_[1] eq 'frmName1')
  ? ("var v=_frmName1.value; _frmName1.value=''; document.body.style.cursor=_frmName1.style.cursor='wait'; window.document.open('" .$_[0]->url ."?_cmd=frmCall;_frmName1=' +encodeURIComponent(v)"
	.",self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length ? '_blank' : '_self'"
	.", '', false); document.body.style.cursor=_frmName1.style.cursor='auto'; return(true);}\">")
  : 1 && ($_[1] eq 'frmName')
  ? ('window.document.DBIx_Web._cmd.value=&quot;frmCall&quot;; '
	.($_[0]->{-menuchs1} && ($_[1] eq 'frmName') 
		? '_frmName1.value=&quot;&quot;; ' 
		: '')
	."if((_frmName.value=='-frame=set') && (self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length)){window.document.DBIx_Web.target='_parent'; _frmName.value=_form.value ? _form.value : ''; if (document.getElementsByName('_...
	."else if(_frmName.value.match(/[+^]\$/) && (self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length)){var v=_frmName.value; _frmName.value=_form.value ? _form.value : ''; window.document.open('" .$_[0]->url ."?_cmd=frmCa...
	#."else {var v=_frmName.value; document.body.style.cursor=_frmName.style.cursor='wait'; _frmName.value=_form.value ? _form.value : ''; window.document.open('" .$_[0]->url ."?_cmd=frmCall;_frmName=' +encodeURIComponent(v) +(document.getElementsByName...
	."else {var v=_frmName.value; _frmName.value=_form.value ? _form.value : ''; _frmName.disabled=true; window.document.open('" .$_[0]->url ."?_cmd=frmCall;_frmName=' +encodeURIComponent(v) +(document.getElementsByName('_frame').length ? ';_frame=' +_f...
	.'window.document.DBIx_Web.submit(); return(false);}">')
  : 'return(true)}')
 ."\n\t"
 .join("\n\t"
	, map { my ($n, $l) =!ref($_) 
			? ($_ , $_[1] !~/^frmName/
				? ucfirst($_[0]->lng(0, $_))
				: !$_
				? '--- ' .$_[0]->lng(0, 'frmCallNew') .' ---'
				: (do {	my($n, $x) =/([+&.^]*)$/ ? ($`, $1) : ($_,'');
					my $o =$_[0]->{-form}->{$n} ||$_[0]->{-table}->{$n};
					$o =$_[0]->lngslot($o,'-lbl') if $o;
					$o =&$o($_[0]) if ref($o);
					($o || ucfirst($_[0]->lng(0, $n)))
					.(!$f1 && $x && (substr($x,0,1) eq '+') ? " $x$x" : '')
					}))
			: ref($_) eq 'ARRAY'
			? ($_->[0]
				, (ref($_->[1]) ? $_[0]->lnglbl($_->[1]) : $_->[1])
				|| ucfirst($_[0]->lng(0, $_->[0])))
			: ($_->{-val}||$_->{-lbl}, $_[0]->lnglbl($_) ||ucfirst($_[0]->lng(0, $_->{-val})));
		$f1 =1	if (!$_ || !$n) && ($_[1] =~/^frmName/);
		'<option ' 
			.($i && ($n eq $i) 
			? do{$i =''; 'selected'}
			: '') 
		.(($n eq '') || ($l =~/^[-]+/)
		 ?(' class="' .$cs .' MenuInputSeparator"')
		 :(' class="' .$cs .'"'))
		.' value="' 
		.htmlEscape($_[0], $n)
		.'">' 
		.htmlEscape($_[0], $l)
		.'</option>'
		} $li
		? (map {if (!(!ref($_) ? $_ : ref($_) eq 'ARRAY' ? $_->[0] : $_) && $li) {
				my $v =$li;
				$li =undef;
				(ref($v) eq 'ARRAY' ? @$v : $v, $_)
			}
			else {
				($_)
			}} @{$_[2]})
		: @{$_[2]}
		, !$li ? () : ref($li) eq 'ARRAY' ? @{$li} : ($li)
	)
 .($i eq ''
  ? ''
  :('<option selected class="' .$cs
	.(($i eq '') || ($i =~/^[-]+/)
	 ? ' MenuSeparator'
	 : '')
	.'" value="'
	.htmlEscape($_[0], $i) .'">' 
		.htmlEscape($_[0]
			, $_[1] =~/^frmName/
			? ($_[0]->{-form} && $_[0]->{-form}->{$i} && $_[0]->lnglbl($_[0]->{-form}->{$i}))
			||($_[0]->{-table} && $_[0]->{-table}->{$i} && $_[0]->lnglbl($_[0]->{-table}->{$i}))
			||$_[0]->lng(0, $i)
			: $_[0]->lng(0, $i))
	.'</option>'))
 ."\n</select>"
 .($_[0]->{-icons} ? '</td>' : '')
}


sub htmlMChs {	# Adjust CGI forms list
 if (!$_[0]->{-menuchs}) {
 $_[0]->{-menuchs} =[];
 if	($_[0]->{-form}) {
	push @{$_[0]->{-menuchs}},
		map {[$_, ($_[0]->lnglbl($_[0]->{-form}->{$_},$_)||$_)]
			} grep {($_ ne 'default')
				&& ((ref($_[0]->{-form}->{$_}) ne 'HASH')
					|| !$_[0]->{-form}->{$_}->{-hide})
				} keys %{$_[0]->{-form}}
 }
 if	($_[0]->{-table}) {
	push @{$_[0]->{-menuchs}},
	map {[$_, ($_[0]->lnglbl($_[0]->{-table}->{$_},$_)||$_)]
		} grep {(ref($_[0]->{-table}->{$_}) ne 'HASH')
					|| !$_[0]->{-table}->{$_}->{-hide}
				} keys %{$_[0]->{-table}}
 }
 @{$_[0]->{-menuchs}} =sort {lc(ref($a) && $a->[1] || $a) cmp lc(ref($b) && $b->[1] || $b)
				} @{$_[0]->{-menuchs}};
 if ($_[0]->{-menuchs} && !$_[0]->uguest()) {
	my @a =( ['','--- ' .lng($_[0], 0, 'frmCallNew') .' ---']
		, map {[$_->[0] .'+', $_->[1] ] # .' ++' # also $f1 in htmlML()
			} grep { my $m;
				  ($m =$_[0]->{-form}->{$_->[0]})
				?  $m->{-field}
				: ($m =$_[0]->{-table}->{$_->[0]})
				? !$m->{-ixcnd}
				: 0
				} @{$_[0]->{-menuchs}}
		);
	if (@{$_[0]->{-menuchs}} <6)	{push @{$_[0]->{-menuchs}}, @a}
	else				{$_[0]->{-menuchs1} =[@a]}
 }}
 if ($_[0]->{-menuchs1}
 && (!ref($_[0]->{-menuchs1}->[0])
	? $_[0]->{-menuchs1}->[0]
	: ref($_[0]->{-menuchs1}->[0]) eq 'HASH'
	? $_[0]->{-menuchs1}->[0]->{-val}
	: $_[0]->{-menuchs1}->[0]->[0])) {
	unshift @{$_[0]->{-menuchs1}}, ['', '--- ' .lng($_[0], 0, 'frmCallNew') .' ---']
 }
 $_[0]->{-menuchs}
}

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

						||$_->{-inp}->{-hrefs}
						||$_->{-inp}->{-rfd}))
						)
					)
			} @{$m->{-field}}])
		if !$q->{-data};
	delete $q->{-data}
		if !$q->{-data}	|| !@{$q->{-data}};
	$q->{-display}=
		   ($m->{-display} && [@{$m->{-display}}])
		|| ($m->{-query} && $m->{-query}->{-display} && [@{$m->{-query}->{-display}}])
		|| ($q->{-data}
			&& [map {  (ref($_) ne 'HASH') 
				|| (($_->{-flg}||'') !~/[al]/i)
				|| !$_->{-fld}
				? ()
				: $_->{-fld}
				} @{$q->{-data}}])
		if !$q->{-display};
	delete $q->{-display}
		if !$q->{-display} || !@{$q->{-display}};
	}
	if (!$q->{-order}) {
		$q->{-order} =
			($m->{-order} && (ref($m->{-order}) ? [@{$m->{-order}}] : $m->{-order}))
			|| ($m->{-query} && $m->{-query}->{-order} && (ref($m->{-query}->{-order}) ? [@{$m->{-query}->{-order}}] : $m->{-query}->{-order}));
		$q->{-keyord} =$m->{-keyord} ||($m->{-query} && $m->{-query}->{-keyord})
			if !$q->{-keyord};
	}
 }
 delete $q->{-meta}	if !$q->{-meta}		|| $qm;
 delete $q->{-field}	if !$q->{-field}	|| !@{$q->{-field}} || $qm;
 delete $q->{-data}	if !$q->{-data}		|| !@{$q->{-data}};
 delete $q->{-display}	if !$q->{-display}	|| !@{$q->{-display}};
 delete $q->{-order}	if !$q->{-order};
 delete $q->{-keyord}	if !$q->{-keyord};
 if ($q->{-data} && ($q->{-display} || $q->{-datainc})) {
	foreach my $e ($q->{-display} ? @{$q->{-display}}: ()
			,$q->{-datainc} ? @{$q->{-datainc}}: ()) {
		my $n =	  !ref($e) ? $e 
			: ref($e) eq 'HASH'	? $e->{-fld}
			: ref($e) eq 'ARRAY'	? $e->[0]
			: undef;
		next	if !$n
			|| (grep {!ref($_)	
				? $_ eq $n
				: ref($_) eq 'HASH'
				? ($_->{-fld}||'') eq $n
				: ref($_) eq 'ARRAY'
				? ($_->[0]||'') eq $n
				: 0
				} @{$q->{-data}});
		push @{$q->{-data}}, $tm && $tm->{-mdefld}->{$e} || $e;
	}
 }
 $q
}



sub htmlMQH {	# Menu Query Hyperlink
 # -label / -html
 # -title, -style, -class, -target; reserved/ignored -tdstyle, -tdclass
 # -qwhere, -qkey, -qurole, -quname, -qorder, -qkeyord
 # -xpar=>0 | 1 | 2 | name | [list]
 # -xkey=>name | [list]
 # -ovw=>sub{}($s, match?, htmlMQH args, query inbound, query formed)
 my $s =$_[0];
 my $a =$#_ ==1 ? $_[1] : {@_[1..$#_]};
 my $qf=	# full inbound query to match required
	$s->{-c}->{-htmbHref}	||do {$s->{-c}->{-htmbHref} =
	{(map {	my $v =$s->{-pcmd}->{$_} ;
		! defined($v) 
		? () 
		: ($_ => $v)
		} qw (-qwhere -qkey -frmLsc -frmLso))
	,(map {	my $v =$s->{-pcmd}->{"-q$_"} 
		|| ($s->{-pcmd}->{-cmdf} && $s->{-pcmd}->{-cmdf}->{-query} && $s->{-pcmd}->{-cmdf}->{-query}->{"-$_"})
		|| ($s->{-pcmd}->{-cmdt} && $s->{-pcmd}->{-cmdt}->{-query} && $s->{-pcmd}->{-cmdt}->{-query}->{"-$_"});
		! defined($v)
		? () 
		: ref($v) eq 'CODE'
		? ("-q$_" => &$v($s, $s->{-pcmd}->{-form}||$s->{-pcmd}->{-table}||'', $s->{-pcmd}->{-cmdf}, $s->{-pcmd}))
		: ("-q$_" => $v)
		} qw (urole uname order keyord))
		}};
 my $qq=	# query reqired
	{map {	($_ =~/^-(?:q|frmLso|frmLsc)/) && defined($a->{$_}) 
			? ($_ => $a->{$_})
			: () 	} keys %$a};
 my $qw=	# writing query joining required
	{ -form => $a->{-form} ||$s->{-pcmd}->{-form}
	, (map {$a->{$_} ? ($_ => $a->{$_}) : ()
		} qw (-cmd -urm))
	, !defined($a->{-xpar}) || ($a->{-xpar} eq '1')	# excluding some
	? (map {$s->{-pcmd}->{$_}
		? ($_ => $s->{-pcmd}->{$_})
		: ()	} qw (-qftext -frmLsc))
	: !$a->{-xpar} || ($a->{-xpar} !~/^\d/)		# excluding list
	? (map {($_ =~/^-(?:q|frmLsc|frmLso)/) && $s->{-pcmd}->{$_}
		? ($_ => $s->{-pcmd}->{$_})
		: () 	} keys %{$s->{-pcmd}})
	: ()};						# excluding all

 if($a->{-xpar} && ($a->{-xpar} !~/^\d/)) {
	delete @$qw{ref($a->{-xpar}) ? @{$a->{-xpar}} : $a->{-xpar}};
 }
 if ($a->{-xkey} && $qw->{-qkey}) {
	$qw->{-qkey} ={%{$qw->{-qkey}}};
	delete @{$qw->{-qkey}}{ref($a->{-xkey}) ? @{$a->{-xkey}} : $a->{-xkey}};
 }
 if (!$qq->{-qwhere} && $qw->{-qwhere}
 && (($qw->{-qwhere} =~/^\[\[(.*?)\]\]/) ||($qw->{-qwhere} =~/^\/\*(.*?)\*\//))
	) {
	$qw->{-qwhere} =$'
 }

 my $ql=800;	# query length limit, was 200
		# MSDN: METHOD Attribute | method Property:
		# the URL cannot be longer than 2048 bytes
 if (length($s->urlCmd('', %$qw)) >$ql) {

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

	delete $qw->{-qjoin};
 }

 my $qm=1;	# query match
 foreach my $k (keys %$qq) {
	next if !defined($qq->{$k});
	my ($vf, $vq) =($qf->{$k}, $qq->{$k});
	if ($qm) {
		$qm =0	if !defined($vf)
			? ( $k eq '-quname'
			  ? !grep /^\Q$vq\E$/i, @{$s->ugnames()}
			  : ($k eq '-frmLso') && defined($qf->{-qurole})
			  ? $vq ne $qf->{-qurole}
			  : 1)
			: $k eq '-qwhere'
			? $vf !~/\Q$vq\E/
			: !ref($vq) && !ref($vf)
			? $vq ne $vf
			: (ref($vq) eq 'ARRAY') || (ref($vf) eq 'ARRAY')
			? (do {	my $v =$s->strdata($vq);
				$s->strdata($vf) !~/^\Q$vq\E/})
			: (ref($vq) eq 'HASH') && (ref($vf) eq 'HASH')
			? (grep {!defined($vf->{$_})
				|| ($s->strdata($vq->{$_}) ne $s->strdata($vf->{$_}))
					} keys %$vq)
			: (ref($vq) xor ref($vf))
			? $s->strdata($vq) ne $s->strdata($vf)
			: $vq ne $vf;
	}
	$qw->{$k} =$k eq '-qkey'
		? ($qw->{$k} && $vq
			? {%{$qw->{$k}}, %$vq}
			: $vq)
		: $k eq '-qwhere'
		? (	 !$vf
			? $vq
			: $vf =~/\Q$vq\E/
			? $vf
			: $vq =~/^(?:\[\[|\/\*)/
			? (do{	$vf =($vf =~/^\[\[(.*?)\]\]/) ||($vf =~/^\/\*(.*?)\*\//)
					? $'
					: $vf;
				$vq .$vf
				})
			: $vq)
		: $vq;
	$qw->{$k} =$vq if length($s->urlCmd('', %$qw)) >$ql;
 }
 $s->{-pcmd}->{-htmlMQH} = $a		if $qm;
 &{$a->{-ovw}}($s,$qm,$a,$qf,$qw)	if $a->{-ovw};
 local $a->{-href}  = $s->urlCmd('', %$qw);
 local $a->{-OnClick}=$s->urlCmd('', %$qw
			, $s->{-pcmd}->{-frame}
			? (-frame=>$s->{-pcmd}->{-frame})
			: ());		# !!! Mozilla no OnLoad target
 local $a->{-target}= '_self'
		if !$a->{-target};
 local $a->{-class} =
	join(' '
		,($s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) : ())
		,('MenuArea MenuComment')
		,($s->{-uiclass} ? ' ' .$s->{-uiclass} : ())
		,($a->{-class} ? $a->{-class} : ())
		,($qm 
		? 'htmlMQH htmlMQHsel' 
		: 'htmlMQH')
		);
 local $a->{-style} =
	join('; '
		,($s->{-c}->{-htmlstyle} ? $s->htmlEscape($s->{-c}->{-htmlstyle}) : ())
		,($qm && 0
		? 'text-decoration: none; font-weight: bolder; border-style: inset;' 
		: ())
		,($s->{-uistyle} ? ' ' .$s->{-uistyle} : ())
		,($a->{-style} ? $a->{-style} : ())
		);

 $s->cgi->a({(map {$a->{$_} ? ($_ => $a->{$_}) : ()
		} qw (-class -style -target -href -title))
		, $a->{-OnClick}
		? (-OnClick=>"window.document.open('" 
			.$a->{-OnClick} ."','_self','',false); return(false)"
			)
		: ()}
	, defined($a->{-html}) 
	? $a->{-html} 
	: defined($a->{-label}) 
	? '<nobr>' .$s->htmlEscape($a->{-label}) .'</nobr>'
	: ($a->{-html} ||$a->{-label}))
}


sub cgiList {	# List queried records
		# self, ?options, form name, ?metadata, ?command, ?iterator, ?borders
 my ($s, $o, $n, $m, $c, $i, $b) =($_[0], substr($_[1],0,1) eq '-' ? @_[1..$#_] : ('-', @_[1..$#_]));
    $m  =$s->{-form}->{$n}||$s->mdeTable($n)||{} if !$m;
    $c  =$s->{-pcmd}||{} if !$c;
 my $mt =$m->{-table} && $s->mdeTable($m->{-table}) || $m;
 my $mf =$c->{-field} || $m->{-field} || $mt->{-field};
 local $c->{-cmdt} =$mt || $m;	# table  meta
 local $c->{-cmdf} =$m  || $mt;	# object meta
 $i =	  !$i
	? $s->cgiSel(%{$m->{-query}}, -form=>$n)
	: ref($i) eq 'HASH'
	? (!($i->{-form} ||$i->{-table})
		? $s->cgiSel(-form=>$n, %$i)
		: $s->cgiSel($i))
	: ref($i) eq 'ARRAY'
	? eval{my $a =$i; DBIx::Web::ccbHandle->new(sub{shift @$a})}
	: ref($i) eq 'CODE'
	? DBIx::Web::dbmCursor->new($i)
	: $i;
 $i ||return(&{$s->{-die}}('cgiList(' .strdata(@_) .') -> cursor undefined' .$s->{-ermd}));
 my $xml=$c->{-xml};
 my $hcls  ='class="'
 		.($s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) .' ' : '')
		.(!$b ? 'ListTable' : 'ListList')
		.($s->{-uiclass} ? ' ' .$s->{-uiclass} : '');
 my $hstl  =$hcls
		.'"'
		.($s->{-uistyle} ? ' style="' .$s->{-uistyle} .'"' : '');

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

					,-form=>$v
						,map {	/^-/
							? ('-q' .$' => $u->{$_})
							: ()
							} keys %$u)}
			,$_[0]->lng(0,'tvmReferences') .':'))
		#. '</div>'
		: $_[0]->cgi->hr();
	local $_[0]->{-uiclass} ='tfvReferences';
	local $_[0]->{-uistyle} ='font-size: small' if 0;
	$_[0]->cgiList('-!h'
	,$v
	,undef
	,{-qhrcol=>0, -qflghtml=>$h, $_[0]->splicekeys(\@o,'-qhrcol|-qflghtml')}
	,{$u ? %$u : ()
	 ,-table=>$v
	 ,-version=>0
	 , $q
	 ?(
	   (map {$_[0]->{-table}->{$v}->{-query} && $_[0]->{-table}->{$v}->{-query}->{$_}
			? ($_ => $_[0]->{-table}->{$v}->{-query}->{$_})
			: ()
			} qw (-display -data -datainc -order -keyord))
	# ,-order=>$_[0]->{-tn}->{-rvcUpdWhen}
	# ,-keyord=>'-dall'
	  ,$_[0]->splicekeys(\@o,'-display|-data|-datainc|-where|-key|-order|-keyord')
	  ,%o
		)
	 :(-field=>[{-fld=>'ir',			-flg=>'q'}
		 ,{-fld=>'id',				-flg=>'q'}
		 ,{-fld=>$_[0]->{-tn}->{-rvcUpdWhen},	-flg=>'ql'}
		 ,{-fld=>$_[0]->{-tn}->{-rvcState},	-flg=>'ql'}
		 ,{-fld=>'subject',			-flg=>'ql'}
		 ,{-fld=>'auser',			-flg=>'ql'}
		 ,{-fld=>'arole',			-flg=>'ql'}
		,ref($f) eq 'ARRAY' ? @$f : ()
		]
	  ,-order=>'-deq'
		)
	,@o
	});
	''
 }
}



sub tvdIndex {	# Template View Definition for Index page
 my $s =$_[0]; return ($s->{-tn}->{'tvdIndex'}=>
 {-lbl		=>sub{$_[0]->lng(0,'tvdIndex')}
 ,-cmt		=>sub{$_[0]->lng(1,'tvdIndex')}
 ,-cgcCall	=>sub{
	my $s =$_[0];
	$s->{-fetched}	=undef;
	$s->{-affected}	=undef;
	local @{$s}{-menuchs, -menuchs1} =@{$s}{-menuchs, -menuchs1};
	$s->htmlMChs()	if !$s->{-menuchs};
	$s->output($s->htmlStart(@_[1,2])	# HTTP/HTML/Form headers
		,$s->htmlHidden(@_[1,2])	# common hidden fields
		,!$s->{-pcmd}->{-print}
		&& $s->htmlMenu(@_[1,2])	# Menu bar
		,"\n<table class=\"ListTable\">\n"
		);
	$s->htmlOnLoad("{var e=document.getElementsByTagName('BASE'); if(e && e[0] && (self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length)){e[0].target='_blank'}}");
	foreach my $e	(($s->{-menuchs} ? @{$s->{-menuchs}} : ())
			,($s->{-menuchs1}? @{$s->{-menuchs1}}: ())
			) {
		my ($n, $l) = ref($e) ? @$e : ($e, $e);
		$l ='--- ' .$_[0]->lng(0, 'frmCallNew') .' ---' if !$n && !$l;
		next if $n eq '-frame';
		my ($o, $a) = $n =~/^(.+?)([+&.]+)$/ ? ($1, $2) : ($n, $n);
		my $l0 =$s->lnglbl($s->{-form}->{$o} ||$s->{-table}->{$o} ||{}, $o)||'';
		my $l1 =$s->lngcmt($s->{-form}->{$o} ||$s->{-table}->{$o} ||{}, $o)||'';
		my $ur1=$s->urlCat('','_form'=>$n,'_cmd'=>'frmCall');
		my $ur2=$s->{-pcmd}->{-frame}
			? $s->urlCat('','_form'=>$n,'_cmd'=>'frmCall','_frame'=>$s->{-pcmd}->{-frame})
			: $ur1;
		$s->output('<tr><th align="left" valign="top"><nobr>'
			, $n
			? $s->cgi->a({-href=>$ur1
				,-title=>  $a =~/[+]/ 
					? $s->lng(1,'frmCallNew') ." '$l0'"
					: $a =~/[&.]/
					? $s->lng(0,'frmCallOpn') ." '$l0'"
					: $s->lng(0,'frmCallOpn') ." '$l0'"
				, $a =~/[+]/		# form
				? (-OnClick=>"window.document.open('$ur1', self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length ? '_blank' : '_self','',false); return(false)"
					# or "this.target = self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length ? '_blank' : '_self'; return(true)";
					)
				: (-target=>'_self'	# list
				  ,-OnClick=>"window.document.open('$ur2', self.name=='TOP' ? '_self': self.name=='BOTTOM' ? 'TOP' : '_self','',false); return(false)"
					# or "this.target = self.name=='TOP' ? '_self' : self.name=='BOTTOM' ? 'TOP' : '_self'; return(true)";
					)
				}
				,(!$s->{-icons}
				? ''
				: '<img border="0" src="' .$s->{-icons} .'/'
				. ( $a =~/[+]/  ? $IMG->{'recNew'}
				  : $a =~/[&.]/ ? $IMG->{'frmCall'}
				  : $IMG->{'recList'}
				  ) .'" />')
				. $s->htmlEscape($l0))
			: $s->htmlEscape($l)
			, "</nobr></th>\n"
			, '<td>&nbsp;</td><td align="left" valign="bottom">'
			, $s->htmlEscape( !$l1 || $l1 ne $l0
					? $l1||''
					: 1
					? $l1||''
					: $a =~/[+]/ 
					? $s->lng(0,'frmCallNew') ." '$l0'"
					: $a =~/[&.]/
					? $s->lng(0,'frmCallOpn') ." '$l0'"
					: $s->lng(0,'frmCallOpn') ." '$l0'"
					)
			, "</td></tr>\n"
			)
		}
	$s->output("\n</table>\n");
	# $s->recCommit();
	$s->cgiFooter() if !$s->{-pcmd}->{-print};
	$s->output($s->htmlEnd());
	$s->end();
	}
	,@_ > 1 ? @_[1..$#_] : ()
 })
}



sub tvdFTQuery {	# Template View Definition for Full-Text Query
 my $s =$_[0]; return ($s->{-tn}->{'tvdFTQuery'}=>
 {-lbl		=>sub{$_[0]->lng(0,'tvdFTQuery')}
 ,-cmt		=>sub{$_[0]->lng(1,'tvdFTQuery')}
 ,-cgcCall	=>sub{
	my $s =$_[0];
	my $g =$s->cgi();
	$s->{-fetched}	=0;
	$s->{-affected}	=undef;
	$s->{-pcmd}->{-cmd} =$s->{-pcmd}->{-cmg} ='recQBF';
	$s->output($s->htmlStart(@_[1,2])	# HTTP/HTML/Form headers
		,$s->htmlHidden(@_[1,2])	# common hidden fields
		,!$s->{-pcmd}->{-print}
		&& $s->htmlMenu(@_[1,2])	# Menu bar
		,"\n"
		);
	$s->die('Microsoft IIS required')	if ($ENV{SERVER_SOFTWARE}||'') !~/IIS/;
	$s->die('Impersonation required')	if (($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/i)
						&& ($s->{-c}->{-RevertToSelf}
							||$s->w32ufswtr());
	$g->param('_qftwhere'
		, defined($g->param('_qftwhere')) && ($g->param('_qftwhere') ne '')
		? $g->param('_qftwhere')
		: defined($g->param('_qftext')) && ($g->param('_qftext') ne '')
		? $g->param('_qftext')
		: '');
	$s->output($g->textfield(-name=>'_qftwhere', -size=>70, -title=>$s->lng(1,'-qftwhere'))
		, '<br />'
		, $g->popup_menu(-name=>'_qftord'
			,-values=>['write','hitcount','vpath','docauthor']
			,-labels=>{
				 'write'	=>'Chronologically'
				,'hitcount'	=>'Ranked'
				,'vpath'	=>'by Name'
				,'docauthor'	=>'by Author'
				}
			,-default=>'write')
		, $g->popup_menu(-name=>'_qlimit'
			,-values=>['',128,256,512,1024,2048,4096]
			,-labels=>{
				 ''  =>"$LIMRS default"
				,128 =>'128  max'
				,256 =>'256  max'
				,512 =>'512  max'
				,1024=>'1024 max'
				,2048=>'2048 max'
				,4096=>'4096 max'
				}
			,-default=>$LIMRS)
		, $g->submit(-name =>'tvdFTQuery_'
			,-value=>$s->lng(0,'recList')
			,-title=>$s->lng(1,'recList'))
		, '' && $g->a({-href=>
			-e ($ENV{windir} .'/help/ix/htm/ixqrylan.htm')
			? '/help/microsoft/windows/ix/htm/ixqrylan.htm'
			: '/help/microsoft/windows/isconcepts.chm' # .'::/ismain-concepts_30.htm'
			}, '?')
		, "<br />\n");

	if ($g->param('_qftwhere') ne '') {
		eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0)');
		Win32::OLE->Initialize();
		# Win32::OLE->Initialize(&Win32::OLE::COINIT_OLEINITIALIZE);
		# Search MSDN for 'ixsso.Query'
		my $oq =Win32::OLE->CreateObject("ixsso.Query");
		!$oq && $s->die("'OLE->CreateObject(ixsso.Query)' failed '$!'/'$@'/" .Win32::OLE->LastError);
		my $ou =Win32::OLE->CreateObject("ixsso.util");
		!$oq && $s->die("'OLE->CreateObject(ixsso.util)' failed '$!'/'$@'/" .Win32::OLE->LastError);
		my $qs =[];
		my $qt =[];
		$oq->{Query} =$g->param('_qftwhere') =~/^(@\w|\{\s*prop\s+name\s+=)/i
				? $g->param('_qftwhere')
				: ('@contents ' .$g->param('_qftwhere'));
		$oq->{Catalog}    ='Web';



( run in 0.568 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )