view release on metacpan or  search on metacpan

lib/CGI/Bus/tm.pm  view on Meta::CPAN

 $r .='</span>' if $r;
 $r
}


sub eval {     # Transaction run
 my $s =shift;
 my $r =ref($_[$#_]) eq 'CODE' ? pop : sub{$s->cmd('-cmd')};
 my $e =undef;
 local $s->parent->{-problem} ='';
 if (!CORE::eval {
   $r =&$r($s);
   1;
 }) {
    $e =$@ ||'Undefined Error';
    $r =undef
 }
 print $s->htmlres(!$e,$e) if $e ||($s->qparamsw('MIN')||'') !~/r/;
 $r
}


sub evaluate { # Execution of tm
 my $s =shift;
 my $p =$s->parent;
 $s->userauthopt;
 $p->{-debug} && $p->{-cache}->{-RevertToSelf}
 && $s->pushmsg('w32IISdpsn(' .(defined($p->{-w32IISdpsn}) ? $p->{-w32IISdpsn} : 'undef') .')'.($p->{-debug} >2 ? ' '. $p->{-cache}->{-RevertToSelf} : ''));
 if (($p->qrun||'') =~/^(SEARCH|SETUP)$/) {
	my $a =$p->{-upws};
	my $w =$p->upws;
	if ($p->qrun eq 'SEARCH') {
		return(undef) if $p->{-cache}->{-RevertToSelf};
		$w->{-searchms} =1
			if !$a
			&& $^O eq 'MSWin32' 
			&& (($ENV{SERVER_SOFTWARE}||'') =~/IIS/);
	}
	return($w->evaluate())
 }
 $s->cmd;
 $s->{-cmdhtm} =sub{$s->cmdhtm(sub{;
 my $rfr =!$s->cmd('-lst') ? 0 
         :(($s->{-lists} && $s->qlst ? $s->{-lists}->{$s->qlst}->{-refresh} : 0) 
          ||$s->{-refresh});
 $p->print->htpgstart(undef
	   ,{-class=>	  $s->cmd('-lst') 
			? 'Form List'
			: $s->cmdg('-qry')
			? 'Form QBF'
			: 'Form'
	   , $rfr
           ? ($p->{-htpgstart} ? %{$p->{-htpgstart}} :()
             ,-head=>(($p->{-htpgstart} && $p->{-htpgstart}->{-head}) 
                    ||($p->{-htmlstart} && $p->{-htmlstart}->{-head})
                    ||'')
             ."<meta http-equiv=\"refresh\" content=$rfr>")
           : $s->cmd('-lst') ||$s->cmd('-hlp')
           ? %{$p->{-htpgstart}}
           : %{$p->{-htpfstart}}});
 # !!!Multipart forms should be escaped as possible: used only for file uploads
 $p->print( $s->{-fsd} && $s->{-fsd}->{-url} 
          && $s->cmdg !~/lst|qry/i
          && !($ENV{MOD_PERL} && $p->cgi->user_agent =~/Lotus-Notes|StarOffice/i)
          ? $s->start_multipart_form(-method=>$rfr ? 'get' : 'post', -action=>$s->qurl, -acceptcharset=>$p->{-httpheader} ?$p->{-httpheader}->{-charset} :undef)
          : $s->startform(-method=>$rfr ? 'get' : 'post', -action=>$s->qurl, -acceptcharset=>$p->{-httpheader} ?$p->{-httpheader}->{-charset} :undef));
 })} if !$s->{-cmdhtm};
 $p->print->htpfstart(undef, {-class=>'Help', %{$p->{-htpgstart}}}) 
		if $s->cmd('-hlp');
 $s->eval();
 $p->print->htpfend if $p->{-cache}->{-htmlstart} ||!$s->cmd('-lst');
}



###################################
# TRANSACTION COMMANDS
###################################


sub cmdchk { # Check / Calculate Data before save
 my $s =shift;
 my $g =$s->cgi;
 my $c =$s->cmd;
 my @diag;
 foreach my $f (@{$s->{-form}}) { 
   next if !ref($f) || ref($f) eq 'CODE' || !$f->{-fld};
   local $_ =$g->param($f->{-fld});
   if (!$s->cmd('-del')) {
      my $n =$f->{-lbl}||$f->{-fld};
      if ($f->{-flg} =~/[mk]/ && $f->{-flg} !~/[g]/ && (!defined($_)|| $_ eq '')) {
            push @diag, $s->lng(1,'fldReq',$n)
      }
      elsif (!$f->{-chk}) {}
      elsif (!ref($f->{-chk})) {
            push @diag, "'$n' !'" .$f->{-chk} ."'" if !CORE::eval $f->{-chk};
      }
      elsif (ref($f->{-chk}) eq 'CODE') {
            push @diag, "'$n'" if !&{$f->{-chk}}($s);
      }
      elsif (ref($f->{-chk}) eq 'ARRAY') {
            push @diag, "'$n' !'" .$f->{-chk}->[1] ."'" if !&{$f->{-chk}->[0]}($s);
      }
   }
   foreach my $c (qw(-frm -sav)) {
      next if !defined($f->{$c});
      $g->param($f->{-fld}, ref($f->{$c}) ? &{$f->{$c}}($s) : $f->{$c})
   }
   if (grep {$c eq $_} qw(-ins -upd -del)) {
      next if !defined($f->{$c});
      $g->param($f->{-fld}, ref($f->{$c}) ? &{$f->{$c}}($s) : $f->{$c})
   }
 }
 $s->die($s->lng(1,'!constr') .': ' .join('; ',@diag) ."\n") if scalar(@diag);
 $s
}



sub cmdcrt { # Create Fields
 my $s   =shift;