view release on metacpan or  search on metacpan

MapDisp2.pm  view on Meta::CPAN

  my @c0 = caller(0); my @c1 = caller(1);
  my $cls = (exists $c1[3]) ? $c1[3] : ''; 
  my $prg = "$cls [$c0[2]] -> $c0[3]"; 

  my $ds = (exists $ar->{dir_sep}) ? $ar->{dir_sep} : '';
     $ds = ($^O =~ /MSWin/i)? '\\': '/'	if ! $ds; 

  # get parent id, server id, study id and list id
  my $vs = 'pid,sid,study_id,list_id,app_user'; 
  my ($pid,$sn,$sid,$lid,$apu) = $s->get_params($vs,$ar); 
    $sn  = $ar->{sel_sn1} if !$sn && exists $ar->{sel_sn1}; 
    $sid = 0 if !$sid; 
    $lid = 0 if !$lid; 

  my $ad 	= eval $s->set_param('all_dir', $ar); 	# all dir array
  my $dir 	= $ad->{$sn}{sas};			# sas dir
     $dir	= join $ds, $dir, $apu;
     
  my $r = []; 				# result array
  if (!$sn) {
    $s->echo_msg("ERR: ($prg) server id is not provided.", 0);
    return wantarray ? @$r : $r;
  } else {
    $s->echo_msg("INFO: ($prg) server id is $sn.", 3);
  } 
  if (! -d $dir) {
    $s->echo_msg("WARN: ($prg) could not find dir - $dir.", 1);
    return wantarray ? @$r : $r;
  } else {
    $s->echo_msg("INFO: ($prg) spec dir is $dir.", 3);
  }
  opendir DD, "$dir" or die "ERR: could not opendir - $dir: $!\n";
  my @a = sort (grep { !/^\./ && !/\.bak$/ && -f "$dir/$_" } readdir DD);
  closedir DD;
  for my $i (0..$#a) { push @$r, [$a[$i],$a[$i],0]; }
  unshift @$r, ['', '__Select__',1]; 

  wantarray ? @$r : $r; 
}


sub mk_dir {
  my ($s, $dir) = @_; 
  # $dir - directory
  
  # $package,   $filename, $line,       $subroutine, $hasargs,
  # $wantarray, $evaltext, $is_require, $hints,      $bitmask
  my @c0 = caller(0); 		my @c1 = caller(1);
  my $cls = (exists $c1[3]) ? $c1[3] : ''; 
  my $prg = "$cls [$c0[2]] -> $c0[3]"; 

  if (! -d $dir) {
    eval { mkpath($dir,0,0777) };
    if ($@) { 
      my $m = "ERR: ($prg [" . __LINE__ . "]) ";
        $m .= "could not mkdir - $dir: $!: $@<br>\n";
      $s->echo_msg($m,0);
      return;
    } 
    if ($^O !~ /^MSWin/i) { 				# non window
        system("chmod -R ugo+w $dir"); 
    }
  }
}

sub backup_file {
  my ($s, $ffn, $ar) = @_; 
  # $ffn - file name
  # $ar  - parameter array 
  # $bdr - backup dir  

  my @c0 = caller(0); my @c1 = caller(1); 
  my $cls = (exists $c1[3]) ? $c1[3] : ''; 
  my $prg = "$cls [$c0[2]] -> $c0[3]"; 

  my $ds = ($^O =~ /MSWin/i)? '\\': '/'; 
  my ($bcp) = $s->get_params('bak_copies',$ar); 
     $bcp = ($bcp) ? $bcp : 10; 	# default it to 10 copies
  my ($fname, $path, $sfx) = fileparse($ffn,qr{\..*});
  
  my $bdr = "${path}baks"; 
  my $f1  = $ffn; 
  my $f2  = join $ds, $bdr, "$fname$sfx"; 
  
  $s->mk_dir($bdr) if (! -d $bdr);

  if (! -f $f2) {
    copy($f1,$f2) or 
      $s->echo_msg("ERR: ($prg [" .__LINE__ . 
      "]) Copy failed from $f1 to $f2: $!",0);
    return; 
  }

  opendir DD, "$bdr" or croak "ERR: ($prg) could not opendir - $bdr: $!\n";
  my @a = sort { (stat("$bdr/$a"))[9] <=>  (stat("$bdr/$b"))[9] } 
               (grep { /$fname/ && !/^\./ } readdir DD);
  closedir DD; 

  my $n = 0; 
  my ($m) = ($a[$#a] =~ /\.(\d+)$/); 
      $m  = 1 + $m; 
  $n = ($m) % $bcp; 
  $n = sprintf "%03d", $n; 
  $f2 = "$f2.$n";
  copy($f1,$f2) or 
      $s->echo_msg("ERR: ($prg [" .__LINE__ . 
      "]) Copy failed from $f1 to $f2: $!",0);
  return; 
}

1;

=head1 HISTORY

=over 4

=item * Version 0.10

This version extracted from MapDips on 07/22/2013.

=item * Version 0.20