view release on metacpan or  search on metacpan

Common.pm  view on Meta::CPAN

  $typ = uc $typ; 
  my $whr = ""; 
  if ($typ =~ /^AND$/i) {
    $whr .= "   $typ $obj "; 
  } elsif ($typ =~ /^ANDNOT/i) {
    if (index($str,',') < 0 && index($str,'%') < 0) {
      $whr .= "   AND $obj ";   
    } else {
      $whr .= "   AND $obj NOT ";   
    } 
  } else { 
    $whr .= "  $typ $obj "; 
  } 
  if (index($str,',') > -1 ) {
    $whr .= " IN ('$str') ";
  } elsif (index($str,'%') > -1) {
    $whr .= " LIKE '$str' ";
  } else {
    $whr .= ($typ =~ /^ANDNOT/i) ? " <>  UPPER('$str') " : " =  UPPER('$str') ";
  }
  $whr .= " ESCAPE '$esc' " if ($esc && index($str,'%') > 0);
  return $whr;
}

=head2 new_form ($q,$ar)

Input variables:

  $q	- CGI class
  $ar	- array ref containing the following variables:
  
Variables used or routines called:

  None

How to use:

Return: None

History: mm/dd/yyyy (developer) - description

  03/28/2011 (htu) - added $add_check, $f_ir, $f_ip, and $add_test
  04/02/2012 (htu) - added $f_if in new_form
  07/22/2013 (htu) - added id for <tr> and JS:<js_code> type

=cut

sub new_form {
  my ($s, $q, $ar) = @_;

  my $prg = 'AppBuilder::Common->new_form';
  my $tsk = $ar->{new_task}; 				# task: add_study
  my $amg = eval $s->set_param('arg_msgs',$ar); 	# arg msgs
  
  if (exists $ar->{guid}) {
    my ($usr_sid,$usr_uid,$usr_tmo) = split /:/, $ar->{guid}; 
    $ar->{user_sid} = $usr_sid 	if $usr_sid =~ /^\d+$/;
    $ar->{user_uid} = $usr_uid	if $usr_uid;
    $ar->{user_tmo} = $usr_tmo	if $usr_tmo; 
  }
  $ar->{encoding} = 'multipart/form-data' if ($tsk && $tsk =~ /^upload_file/i);

  if (!exists $amg->{$tsk}) {
    $s->echo_msg("ERR: ($prg) could not find new task - $tsk.",0); 
    return; 
  }
  my ($pid,$sid,$t,$t1,$t2) = (); 
     $pid = $ar->{pid} if (exists $ar->{pid} && $ar->{pid}); 
     $sid = $ar->{sid} if (exists $ar->{sid} && $ar->{sid});
     $sid = $ar->{study_id} if (!$sid && exists $ar->{study_id});
     $sid = $ar->{sel_sn1} if (!$sid && exists $ar->{sel_sn1}); 
  my $usr_gid = (exists $ar->{guid}) ? $ar->{guid} : "";      
  my $ksb = eval $s->set_param('var2sub',$ar);     
  my $far = $amg->{$tsk}; 				# form message
  my $cls = eval $s->set_param('code_lists',$ar);	# code lists
 
  my $f_in  = "<input name=\"%s\" value=\"%s\" />"; 
  my $f_ih  = "  <input type=\"hidden\" name=\"%s\" value=\"%s\" />\n"; 
  my $f_ir  = "  <input name=\"%s\" value=\"%s\" readonly/>\n"; 
  my $f_ip  = "  <input type=\"password\" name=\"%s\" value=\"%s\" />\n"; 
  my $f_if  = "  <input type=\"%s\" name=\"%s\" />\n"; 
  my $f_st  = "\n<select name=\"\%s\"  class='formField' %s>\n%s</select>\n  "; 
  my $f_sm  = "\n<select name=\"\%s\"  multiple='multiple' %s>\n%s</select>\n  "; 
  my $f_op  = "  <option value=\"%s\">%s</option>\n"; 
  my $f_os  = "  <option selected value=\"%s\">%s</option>\n";  
  my $f_tr  = "<tr id='%s'>\n  <td>%s</td>\n  <td>%s</td>\n  <td>%s</td>\n</tr>\n"; 
  my $f_tb  = "<table align=center>\n<caption>%s</caption>\n%s\n</table>\n"; 
  my $f_fm  = "<form method=\"$ar->{method}\" action=\"$ar->{action}?\" ";
     $f_fm .= "enctype=\"$ar->{encoding}\" name=\"oraForm\" ";
     $f_fm .= "target=\"%s\">\n%s\n</form>\n";

  my $title = $tsk; $title =~ s/_/ /g; $title = '<b>' . uc($title) . '</b>'; 
  my $add_check = 0;
  my $add_test  = 0; 
  my $test_label = '';
  my $chk_label  = '';

# $s->disp_param($ar);

  for my $i (0..$#$far) {		# each variable
    my $k = $far->[$i][0];		# name/key: study_id
    my $m = $far->[$i][1];		# message
    my $d = $far->[$i][2];		# default value
    my $n = $far->[$i][3];		# desc/required
    my ($k1,$k2) = ($n =~ /^([^:]+):?(.*)?/);
    
    if ($k =~ /^a/i && $n =~ /^check/i) {
      ++$add_check;  $chk_label = ucfirst($n); next; 
    }
    if ($k =~ /^a/i && $n =~ /^test/i) {
      ++$add_test;  $test_label = ucfirst($n); next; 
    }
    if ($n && $n =~ /^hidden/i) {
      $d = (!$d && exists $ar->{$k}) ? $ar->{$k} : $d; 
      $t .= sprintf $f_ih, $k, $d; next; 
    }
    if (exists $ksb->{$k}) {
      my $sub = $ksb->{$k}; 
      my $kkk = $s->$sub($ar); 
      $cls->{$k} = $kkk; 
      # print "Sub: $sub, $k, $kkk<br>\n";