view release on metacpan or  search on metacpan

TaskLoads.pm  view on Meta::CPAN

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

  my $prg = 'TaskLoads::ld_mdrstd';
  # 0. prepare parameters and check parameters
  $s->echo_msg(" 0. running $prg...", 1);
  my ($sid, $jid, $hid) = ();
  $sid = $ar->{study_id} 	if exists $ar->{study_id}
         && ($ar->{study_id} || $ar->{study_id} == 0);
  $jid = $ar->{job_id}  	if exists $ar->{job_id}
         && ($ar->{job_id} || $ar->{job_id} == 0);
  $hid = $ar->{hjob_id}  	if exists $ar->{hjob_id}
         && ($ar->{hjob_id} || $ar->{hjob_id} == 0);

  if ($sid != 0 && !$sid) {
    $s->echo_msg("ERR: ($prg) Study ID is required.", 0); return;
  }

  my $ds = ($^O =~ /MSWin/i) ? '\\' : '/';
  my $pid	= $ar->{pid};				# parent id
  my $sn 	= $ar->{sid}; 				# server id
  my $ad 	= eval $s->set_param('all_dir', $ar); 	# all dir array

  my $dir 	= $ad->{$sn}{mdr};			# mdr/map dir
  #  my $sqlout	= $ad->{$sn}{sqlout};			# sql output dir
  #  my $odr	= "$sqlout$ds$sn";
  $s->echo_msg("INFO: ($prg) dir=$dir",1);
  croak "ERR: ($prg) could not find dir - $dir." if ! -d $dir;

  # 1. get cfg information
  $s->echo_msg(" 1. get cfg info for study $sid...", 1);

  my $rp = $s->get_ldrcfg($ar);
  croak("ERR: ($prg) loader cfg is not defined.") if ! %$rp;
  croak("ERR: ($prg) loader cfg is not defined for study id - $sid.")
    if ! exists $rp->{$sid};

  my $vrs = 'dn_tab,vn_tab,sl_col,fk_col,fk_var,dn_key,vn_key';
  for my $k (split /,/, $vrs) {
    croak "ERR: ($prg) missing variable $k." if ! exists $rp->{$sid}{var}{$k};
  }
  my $rdr = join $ds, $dir, $rp->{$sid}{rdr};
  my $mfn = $rp->{$sid}{mfn};
     $mfn = ($mfn) ? (join $ds,$rdr,$mfn) : '';
  my $dfn = ($mfn) ? $rp->{$sid}{dfn} : (join $ds, $rdr,$rp->{$sid}{dfn});
  my $vfn = ($mfn) ? $rp->{$sid}{vfn} : (join $ds, $rdr,$rp->{$sid}{vfn});
  my $sdr = strftime "%Y$ds%m$ds%d", localtime;
  my $ofd = join $ds, $dir, $rp->{$sid}{ofd}, $sdr;

  my $dml_type = $rp->{$sid}{dml};
     $dml_type = ($dml_type) ? $dml_type : 'A';

  if (!-d $rdr) {
      croak "ERR: ($prg) could not find - $rdr<br>\n";
  }
  if (!-d $ofd) {
      $s->echo_msg("INFO: ($prg) make dir - $ofd.", 2);
      eval { mkpath($ofd,0,0777) };
      # mkdir $ofd;
      croak "ERR: ($prg) could not mkdir - $ofd: $!: $@<br>\n" if ($@);
      system("chmod -R ugo+w $ofd") 		if ($^O !~ /^MSWin/i); 	# non window
  }

  if ($mfn && ! -f $mfn) {
    croak "ERR: ($prg) could not find mfn file - $mfn";
  }
  $s->echo_msg("INFO: ($prg) RDR=$rdr",1);
  $s->echo_msg("INFO: ($prg) OFD=$ofd",1);
  $s->echo_msg("INFO: ($prg) MFN=$mfn",1);


  # 2. read the XLS file
  $s->echo_msg(" 2. read configuration files...", 1);
  my ($dr, $vr) = ();
  if ($mfn) {
    my $n1 = $rp->{$sid}{dfn};
    my $n2 = $rp->{$sid}{vfn};
    $s->echo_msg("INFO: MFN - $mfn ($n1,$n2).", 1);
    $dr  = $s->read_xls($mfn, $n1);
    $vr  = $s->read_xls($mfn, $n2);
  } else {
    $s->echo_msg("INFO: DFN - $dfn.", 1);
    $dr  = $s->read_cfg_file($dfn,'A',',');
    $s->echo_msg("INFO: vFN - $vfn.", 1);
    $vr  = $s->read_cfg_file($vfn,'A',',');
  }

# $s->disp_param($dr);
# $s->disp_param($vr);

  $s->echo_msg("INFO: ($prg) no of records for domain: $#$dr", 1);
  $s->echo_msg("INFO: ($prg) no of records for variable: $#$vr", 1);

  $s->echo_msg($dr, 5);
  $s->echo_msg($vr, 5);

  # 3. build SQL statement for cc_domains
  $s->echo_msg(" 3. build sql statement for cc_domains...", 1);
  my $sql 	= [];		# sql array
  my $rf	= {};		# ref for ldr parameter
     $rf->{tbn} = $rp->{$sid}{var}{dn_tab};
     $rf->{kcn} = $rp->{$sid}{var}{dn_key};
     $rf->{scn} = $rp->{$sid}{var}{sl_col};
     $rf->{scv} = $sid;
     $rf->{act} = $rp->{$sid}{dml};

  $rf->{dn_fmt} = '';
  $rf->{del_ctb} = '';
  $rf->{del_ptb} = '';
  if ($rf->{act} =~ /^D/i) {
    # delete child table first
    my $ptb = $rp->{$sid}{var}{dn_tab};
    my $ctb = $rp->{$sid}{var}{vn_tab};
    my $fkc = $rp->{$sid}{var}{fk_col};
    my $fkn = $rp->{$sid}{var}{fk_var};
    my $scn = $rp->{$sid}{var}{sl_col};
    my $t  = "PROMPT Deleting $ctb with $scn = $sid...\n";
       $t .= "DELETE $ctb WHERE $fkc IN (\n";
       $t .= "  SELECT $fkc FROM $ptb WHERE $scn = $sid);\n";
       $t .= "commit;\n\n";
    $rf->{del_ctb} = $t;