#! /usr/local/bin/perl
################################################################################
#
#  Miscellaneous Tools
#
#  copyright (c)
#    Fritz Lipmann Institute Jena, Genome Analysis Group, 2006, 2013
#    Karol Szafranski at UPenn Philadelphia, Center for Bioinformatics, 2004
#    Institute of Molecular Biotechnology Jena, Dept. Genome Analysis, 1999-2004
#  author
#    Karol Szafranski, karol.szafranski@leibniz-fli.de
#
################################################################################
#
#  DESCRIPTION
#
# - See function &usage for description of command line syntax
#
# - each function comes along with a description at the beginning of the code
#   block
#
################################################################################
#
#  FUNCTIONS, DATA
#
# - MAIN
#   %GlobStore
#   $ProgFile,$ProgFstump
#   $ProgMode,%ProgOpt,@ProgArg
#
# - usage help, command line arguments
#   &usage
#   &AddSwitch
#
# - physical file actions, file & process monitoring
#   &ProgTruncate
#   &ProgFindATimeSec
#
# - logical file handling
#   &ProgDataAccess
#   &ProgLrange
#   &ProgPerlFunc
#   &ProgPerlDepd
#    &PerlTurnsComment
#
# - miscellaneous functions
#   &ProgBaylorMiss
#   &ProgMemOflow
#   &ProgRound
#
################################################################################


# global constants and variables
# also used by modules as a unique global data anchor
our %GlobStore;

# include path(s), includes
use strict; #use warnings;  # OK 20040813
use Cwd qw(realpath);
BEGIN {
  unshift @INC, grep{$_} split(/:+/,$ENV{KPERLPATH}||$ENV{PERLPATH}||'');
  my ($mypath) = realpath(__FILE__)=~m/(^.*)\//;
  push @INC, $mypath;
}
use MainLib::StrRegexp;
use MainLib::Data;
use MainLib::Path;
use MainLib::Cmdline qw(&GetoptsNArgs);
use MainLib::File;
use MainLib::Misc;
use MainLib::Graphics;
use database::DbPlain qw(&PlainToTable);


# script ID
# - program name as specified on the command line
our $ProgFile = ( split('/',__FILE__) )[-1];
our $ProgFstump=$ProgFile; $ProgFstump=~s/\.\w{1,4}$//;


# manage I/O #####################################

# organiz I/O handles
&Unbuffer();
binmode STDOUT;


# command line interface #########################
# NOTE:
# - &GetoptsNArgs (via &AddSwitch) modifies global variables:
#   $ProgMode @ProgArg %ProgOpt
# - @ProgArg may be pre-filled in &GetoptsNArgs via &AddSwitch (option -fofn)

# arguments, switches, default subprogram
our $ProgMode = undef;
our @ProgArg = ();
our %ProgOpt = ();
@ProgArg = &GetoptsNArgs();

# eventually open LOG file
if ($ProgOpt{-log}) {
  $ProgOpt{LogFile} = ($ProgOpt{-log} ne '1')? $ProgOpt{-log} : undef;
  &LogOpen (-file=>$ProgOpt{LogFile}, -stamp=>$ProgFstump, -prog=>"$ProgFile -$ProgMode");
}
END {
  $ProgOpt{-log} and &LogClose();
}


# work flow manifold #############################

# chain to program mode which is optionally argument-less
my $arg;
if (0) { }
elsif ($ProgMode eq '') {  # there is no default ModeSwitch!
  print STDERR "ERROR: missing mode switch\n";
  &usage();
}
elsif ($ProgMode =~ m/^BaylorMiss$/i) {
  &ProgBaylorMiss();
  exit 0;
}
elsif ($ProgMode =~ m/^ColorLib$/i) {
  foreach $arg (sort keys %ColorLib) {
    printf "%s  (%d,%d,%d)\n", $arg, @{$ColorLib{$arg}};
  }
  exit 0;
}
elsif (!@ARGV or $ProgMode =~ m/^h(elp)?$/i) { &usage() }
elsif ($ProgMode =~ m/^PerlIncEff$/i) {
  printf "%s\n", join (' ', @INC);
  exit 0;
}
elsif ($ProgMode =~ m/^MemOflow$/i) {
  &ProgMemOflow();
  exit 0;
}
elsif ($ProgMode =~ m/^Time(Sec)?$/i) {
  printf "%s\n", $1 ?
    time : &TimeStr (-time=>$ProgArg[0]||time, -format=>$ProgOpt{-format}, -zone=>'local');
  exit 0;
}

# ensure input argument(s)
unless (@ProgArg) {
  die "ERROR: missing arguments\n";
}

# chain to program mode (with input argument(s))
if (0) { }
elsif ($ProgMode =~ m/^ATime(Sec(Diff)?)?$/i) {
  unless (-e $ProgArg[0]) {
    die sprintf "ERROR: file %s does not exist\n", $ProgArg[0];
  }
  printf "%s\n",
    $2 ? (time - &atime ($ProgArg[0])) :
   ($1 ? &atime ($ProgArg[0]) :
         &TimeStr (-time=>&atime($ProgArg[0]), -format=>$ProgOpt{-format}, -zone=>'local')
    );
}
elsif ($ProgMode =~ m/^binsplit$/i) {
  my $iSplit = shift @ProgArg;   # we are sure to have this argument
  if ($iSplit =~ m/\D+/) {
    die sprintf "ERROR: arg1 (\"%s\") must be numeric\n", $iSplit;
  }
  foreach $arg (@ProgArg) {
    &ProgBinsplit ($arg,$iSplit);
  }
}
elsif ($ProgMode =~ m/^DataAccess$/i) {
  &ProgDataAccess (@ProgArg);
}
elsif ($ProgMode =~ m/^expr$/i) {
  require Math::kCalc; Math::kCalc->import();
  my $expr=join(' ',@ProgArg);
  $ProgOpt{-debug} and printf STDERR "%s. evaluating: %s\n",
    join('',__PACKAGE__,', line ',__LINE__), $expr;
  printf "%s\n", (eval $expr) || '0';
}
elsif ($ProgMode =~ m/^FindATimeSec$/i) {
  unless (-e $ProgArg[1]) {
    die sprintf "ERROR: file %s does not exist\n", $ProgArg[1];
  }
  &ProgFindATimeSec (@ProgArg);
}
elsif ($ProgMode =~ m/^FSize$/i) {
  unless (-e $ProgArg[0]) {
    die sprintf "ERROR: file %s does not exist\n", $ProgArg[0];
  }
  printf "%d\n", -s($ProgArg[0]);
}
elsif ($ProgMode =~ m/^FTime(Sec(Diff)?)?$/i) {
  unless (-e $ProgArg[0]) {
    die sprintf "ERROR: file %s does not exist\n", $ProgArg[0];
  }
  printf "%s\n",
    $2 ? (time - &ftime($ProgArg[0])) :
   ($1 ? &ftime($ProgArg[0]) :
         &TimeStr (-time=>&ftime($ProgArg[0]), -format=>$ProgOpt{-format})
    );
}
elsif ($ProgMode =~ m/^lrange=(.+)$/i) {
  require Math::Range;
  $ProgOpt{Lrange} = Math::Range->new_parsed($1);
  unless (ref ($ProgOpt{Lrange})) {
    die "ERROR: invalid range argument $1\n";
  }
  foreach $arg (@ProgArg) {
    &ProgLrange ($arg);
  }
}
elsif ($ProgMode =~ m/^mode$/i) {
  unless (-e $ProgArg[0]) {
    die sprintf "ERROR: file %s does not exist\n", $ProgArg[0];
  }
  printf "%04o\n", (stat($ProgArg[0]))[2] & 07777;
}
elsif ($ProgMode =~ m/^owner$/i) {
  printf "%s\n", &owner($ProgArg[0]);
}
elsif ($ProgMode =~ m/^PathExpand$/i) {
  foreach $arg (@ProgArg) {
    printf "%s\n", &realpath($arg);
  }
}
elsif ($ProgMode =~ m/^PerlDepd$/i) {
  &ProgPerlDepd (@ProgArg);
}
elsif ($ProgMode =~ m/^PerlFunc$/i) {
  &ProgPerlFunc (@ProgArg);
}
elsif ($ProgMode =~ m/^round$/i) {
  &ProgRound (@ProgArg);
}
elsif ($ProgMode =~ m/^truncate$/i) {
  my $iTrunc = shift @ProgArg;   # we are sure to have this argument
  if ($iTrunc =~ m/\D+/) {
    die sprintf "ERROR: arg1 (\"%s\") must be numeric\n", $iTrunc;
  }
  foreach $arg (@ProgArg) {
    &ProgTruncate ($arg,$iTrunc);
  }
}
else {
  print STDERR "ERROR: unknown program mode or switch '$ProgMode'\n";
}

# exit script successfully
# cf. END blocks!
exit 0;


################################################################################
# usage help, command line arguments
################################################################################


sub usage {
  print "\n";
  print <<END_USAGE;
DESCRIPTION
 Collection of miscellaneous Perl routines.

COMMAND LINE SYNTAX
 $ProgFile  -<ModeSwitch> [-<OptionalSwitch> ...] <Arg1> [<Arg2> ...]

path arguments:
 Path "-" resolves to STDIN or STDOUT, depending on the context.

ModeSwitch (case-insensitive)
-----------------------------
-ATime            time of access/modification of file, formatted string
                  Arg1       file(s)
                  -format=S  time format, syntax as for shell command \`date\´,
                             default: "$MainLib::StrRegexp::TimeStrDft"
-ATimeSec         like -ATime, seconds since Jan. 1, 1970
-ATimeSecDiff     like -ATime, difference from now in seconds
-BaylorMiss       list dicty Baylor reads which are missing as Sample files
-binsplit         split file to array of files having specified length
                  Arg1       split length
                  Arg2+      files
-ColorLib         display definitions in color library
-DataAccess       access entry from ressource data file
-FindATimeSec     return list of file(s) filtered for minimum last access
                  time (mesured in seconds back from now)
                  Arg1       atime threshold
                  Arg2       filename
-FSize            size of file, formatted string
                  Arg1+      file(s)
-FTime            time of modification of file, formatted string
                  Arg1       file(s)
                  -format=S  time format, syntax as for shell command \`date\´,
                             default: "$MainLib::StrRegexp::TimeStrDft"
-FTimeSec         like -FTime, seconds since Jan. 1, 1970
-FTimeSecDiff     like -FTime, difference from now in seconds
-h(elp)           output command line syntax description and exit
-lrange=N1..N2    extract range of lines from text input. This works the same
                  as a combination of UNIX commands \`head\´ and \`tail\´.
-MemOflow         provoke memory overflow
-mode             get actual file flags, octal format
-owner            determine owner of a file
-PathExpand       return expanded path(s) of path specifier argument(s)
-PerlDepd         check dependencies between perl module and some other
                  pieces of code
                  Arg1       perl module
                  Arg2+      other pieces of code
-PerlFunc         extract function section from perl code
                  Arg1       path of perl code
                  Arg2       name of perl function
-PerlIncEff       effective perl include paths (environment and inline)
-round            do rounding of number
                  Arg1       input number
                  Arg2?      rounding step, default: 1
-Time             local time, formatted string. This is pretty much the same
                  as UNIX command "date".
                  -format=S  time format, syntax as for shell command \`date\´,
                             default: "$MainLib::StrRegexp::TimeStrDft"
-TimeSec          like -Time, seconds since Jan. 1, 1970
                  Arg1*      display this time, seconds since Jan. 1, 1970
-truncate         truncate/fill file to specified length. A non-existing
                  file will be generated.
                  Arg1       length
                  Arg2+      files
                  --truncmsg=1
                             append a standard message to the truncated file

OptionalSwitch (case-insensitive)
---------------------------------
switch argument types: B:=boolean, F:=floating point/scientific, N:=integer,
S:=string, X:=varying type.

-debug(=N)        print debug protocol to STDERR (sometimes STDOUT).
                  N          debug depth value
-format=S         user-defined format scheme
-log(=S)          redirect STDOUT and STDERR to LOG file
                  S          log file path, default path worked out
                             automatically from built-in directives.
-v(erbose)        print extended progress report to STDOUT.
--*               function-specific switches. See the descriptions there.
END_USAGE
  print "\n";
  exit 0;
}


# add program switches to global table (hash)
#
# INTERFACE
# - argument 1:  switch argument without leading '-'
#
# - global data:
#   $ProgMode
#   %ProgOpt     switch data which gets processed here
#
# DESCRIPTION
# - this function gets called by &MainLib::Misc::GetoptsNArgs
# - switch arguments are tested for validity. Arguments are parsed with highest
#   possible tolerance. This way, syntax errors can reported in accordance to
#   the actual switch, rather than reporting ANY syntax error.
#
sub AddSwitch {
  my $switch = shift;

  # optional switches
  if ($switch =~ m/^debug(=(\d+))?$/i) {
    $ProgOpt{-debug} = defined($2) ? int($2) : 1;
    return;
  }
  if ($switch =~ m/^t?Format=(.+)$/i) {
    $ProgOpt{-format} = $1;
    return;
  }
  if ($switch =~ m/^log(=(.*))?$/i) {
    $ProgOpt{-log} = $2 ? &PathExpand($2) : 1;
    return;
  }
  if ($switch =~ m/^v(erbose)?$/i) {
    $ProgOpt{-verbose} = 1;
    return;
  }
  if ($switch =~ m/^(?:-|var=)(\w+)[,=](.+)$/i) {
    $ProgOpt{-var}{$1} = $2;
    return;
  }

  # switch "mode"
  if (defined $ProgMode) {
    printf STDERR "ERROR: multiple specification of program mode or unknown switch, %s and %s\n",
      '-'.($ProgMode||"''"), '-'.($switch||"''");
    exit 1;
  }
  else {
    $ProgMode = $switch;
  }
}


################################################################################
# physical file actions, file & process monitoring
################################################################################


# truncate file
#
# INTERFACE
# - argument 1: file path
#
# DESCRIPTION
# - A non-existing file will be generated.
#
sub ProgTruncate {
  my ($PathFile,$len) = @_;

  # skip directories
  if (-d $PathFile) {
    print  STDERR "ERROR: $PathFile is a directory\n";
    return;
  }

  # generate non-existing file
  if (! -e $PathFile) { &touch ($PathFile) }

  # create the verbose message
  my $TruncMsg = "\n[truncated]\n";
  if ($ProgOpt{-var}{truncmsg}) { $len -= length($TruncMsg) }

  # truncate, Perl's built-in working via system command
  truncate ($PathFile, $len);

  if ($ProgOpt{-var}{truncmsg}) {
    &WriteFile ($PathFile, $TruncMsg, -append=>1)
  }
}


# split file
#
# INTERFACE
# - argument 1: file path
#
sub ProgBinsplit {
  my ($PathFile,$len) = @_;
  my $verbdbg = $ProgOpt{-verbose} || $ProgOpt{-debug};

  # skip directories
  if (-d $PathFile) {
    print  STDERR "WARNING: $PathFile is a directory -- skipped\n";
    return;
  }
  # generate non-existing file
  if (! -e $PathFile) {
    print  STDERR "WARNING: $PathFile does not exist -- skipped\n";
    return;
  }

  # create the verbose message
  my $hIn=FileHandle->new($PathFile);
  for (my $i=0; !$hIn->eof(); ++$i) {
    my $fout = "$PathFile.$i";
    if ($verbdbg) { print "$fout\n" }
    my $hOut = FileHandle->new($fout,'w');
    my $d; $hIn->read($d,$len);
    print $hOut $d;
  }
}


# grep file list for minimal access time
#
# DESCRIPTION
# - this is a variant of the shell command 'find -atime'. The difference
#   is the measure (seconds versus days).
#
sub ProgFindATimeSec {
  my ($ATimeArg, @path) = @_;
  my ($ATimeMin);

  # function parameters
  unless ($ATimeMin = int $ATimeArg) {
    print STDERR "ERROR: first argument is not numeric: $ATimeArg\n";
    exit 1;
  }

  # loop over paths, output &atime
  foreach (@path) {
    if (time - &atime ($_) > $ATimeMin) {
      print "$_\n";
    }
  }
}


################################################################################
# logical file handling
################################################################################


# access entry from ressource data file
#
# INTERFACE
# - argument 1: path of ressource data file
# - argument 2: label of data entry
#
sub ProgDataAccess {
  my ($PathData, $EntryLbl) = @_;
  my ($debug, $dbg2);
  my ($pData, $pSlc, $entry);

  # function parameters
  $debug = $ProgOpt{-debug};
  $dbg2  = $debug ? $debug-1 : undef;

  # load data from file
  unless ($pData = &DataRead ($PathData)) {
    print  STDERR "ERROR: unable to read file $PathData\n";
    return;
  }

  # access requested entry
  $pSlc = [ map { [$_, undef] } split (/::/, $EntryLbl) ];
  $entry = (&DataTreeSlc($pData, $pSlc, -debug=>$dbg2) || [undef])->[0];

  # reformat
  printf "%s\n", $entry;
}


# extract range of lines from text input
#
# INTERFACE
# - argument 1: file path
#
# - global data:
#   $ProgOpt{Lrange}  range argument
#
# DESCRIPTION
# - counting logics is human
#
sub ProgLrange {
  my ($PathFile) = @_;
  my ($hIn);

  # open/check input file
  unless ($hIn = FileHandle->new($PathFile)) {
    print  STDERR "ERROR: unable to read file $PathFile\n";
    return;
  }

  # skip leading lines
  while (($.+1)<$ProgOpt{Lrange}{-1} and defined(<$hIn>)) { }

  # output requested lines
  while ($.<$ProgOpt{Lrange}{1} and defined($_=<$hIn>)) { print }
}


# extract function section from perl code
#
# INTERFACE
# - argument 1: path of perl code
# - argument 2: name of function
#
sub ProgPerlFunc {
  my ($PathCode, $FuncName) = @_;
  my ($hIn, @LineHad, @LineSlc);
  my ($CtI);

  # find offset of function code
  $hIn = FileHandle->new($PathCode);
  while (<$hIn>) {
    push @LineHad, $_;
    if (m/^sub\s+$FuncName\b/) {
      for ($CtI=$#LineHad-1; $CtI>=0; $CtI--) {
        if ($LineHad[$CtI] !~ m/^\#/) { last }
      }
      @LineSlc = splice @LineHad, $CtI+1;
      last;
    }
  }
  undef @LineHad;

  # sample lines until end of function code
  while (<$hIn>) {
    push @LineSlc, $_;
    if (m/^\}/) { last }
  }

  # function parameters
  print  @LineSlc;
}


# check dependencies between perl module and some other pieces of code
#
# INTERFACE
# - argument 1:  path of perl module
# - argument 2+: path(s) of higher order perl code
#
# - global options:
#   -debug       [STD]
#
# DEBUG, CHANGES, ADDITIONS
# - With increasing usage of "require" for dynamic package loading, this routine
#   does not accurately detect imported packages anymore.
#
sub ProgPerlDepd {
  my ($PathMod, @PathHOrder) = @_;
  my ($debug, $dbg2);
  my ($CodePlain, $CodeSkipped, $package, @smb);
  my ($ItHOrder, %code);

  # function parameters
  $debug = $ProgOpt{-debug};
  $dbg2  = $debug ? $debug-1 : undef;
  $PathMod = &PathExpand ($PathMod);

  ##############################################################################
  # analyse module

  # load module
  $debug and printf STDERR "%s. module file: %s\n", &MySub, $PathMod||"''";
  $CodePlain = &ReadFile ($PathMod);
  $CodePlain =~ m/package +([^);]+);/;
  push @smb, {
    str    => $package = $1,
    regexp => '[^#\']'. $package .'\b',
    };

  # sample exportes symbols
  if ($CodePlain =~ m/use +Exporter/ and $CodePlain =~ m/\@EXPORT *= *qw *\(([^)]+)\)/s) {
    $CodePlain = $1;
    $CodePlain =~ tr/\n//d;
    #$debug and printf STDERR "%s. exported symbols plain: %s\n", &MySub, $CodePlain||"''";
    foreach my $ItSmb (grep{$_} split(/[ \t\n]+/s,$CodePlain)) {
      push @smb, {
        str    => $ItSmb,
        # '^[^\n#]+' or '^[^#\n]+' cause runtime segmentation faults!
        regexp => '[^\\\\]('. join ('|', "\\$ItSmb\\b",
                  $ItSmb=~m/^\%/ ? ("\\\$$'\\\{") : (),
                  $ItSmb=~m/^\@/ ? ("\\\$$'\\\{") : (),
                  ) .')',
        };
    }
  } elsif ($debug) {
    printf STDERR "%s. module is not an Exporter\n", &MySub;
  }

  # load debug
  if ($debug) {
    printf STDERR "%s. module is package: %s\n", &MySub, $package||"''";
    printf STDERR "%s. exported symbols: %s\n", &MySub, int(@smb)||'NONE';
    &DataPrint (\@smb, -space=>2, -handle=>\*STDERR);
  }

  ##############################################################################
  # analyse higher-order code

  # loop over higher-order code units (programs and modules)
  foreach $ItHOrder (@PathHOrder) {
    $code{$ItHOrder}{path} = &PathExpand ($ItHOrder);
    $debug and printf STDERR "%s. inspecting dependency in code: %s\n", &MySub,
      $code{$ItHOrder}{path};

    # load extra piece of code
    $CodePlain = &ReadFile ($ItHOrder);

    # grab 'package' line
    if ($CodePlain =~ m/package +([^);]+);/) {
      $code{$ItHOrder}{package} = $1;
      if ($code{$ItHOrder}{package} eq $package) {
        delete $code{$ItHOrder};
        next;
      }
    }

    # grab 'use' line for current package
    # - with this regexp we won't grab "use" lines at the very beginning of
    #   the file
    # - "use" statements are identified only if overlapping one single line
    $CodeSkipped = '';
    if ($CodePlain =~ m/\n[^#]*use +$package(?: +qw *\(([^);]+)\)| *\(()\))? *;/) {
      my $UsePlain = $1 || $2;
      $CodeSkipped = $` . $&;
      $CodePlain = $';

      # package specifier is always implicitly imported
      $code{$ItHOrder}{imports} = defined($UsePlain) ?
        [ $package, grep{$_} split(/[ \t\n]+/s,$UsePlain) ] :
        [ map { $_->{str} } @smb ];
      $code{$ItHOrder}{explic_imp} = defined($UsePlain) ? 1 : 0;
      $code{$ItHOrder}{ImportIdx} = { map { ($_,1) } @{$code{$ItHOrder}{imports}} };
    }

    # trace and validate usage of symbols
    foreach my $ItSmb (@smb) {
      # primary trace using &MatchIdx
      $code{$ItHOrder}{uses}{$$ItSmb{str}} = &MatchIdx (\$CodePlain, $$ItSmb{regexp});
      $debug and printf STDERR "%s. symbol %s (regexp %s), primary matches: %d\n", &MySub,
        $$ItSmb{str}, $$ItSmb{regexp}, int @{$code{$ItHOrder}{uses}{$$ItSmb{str}}};
      # occurrence not inside true comment (cmp. &PerlTurnsComment)
      for (my $CtMatch=0; $CtMatch<@{$code{$ItHOrder}{uses}{$$ItSmb{str}}}; $CtMatch++) {
        my $pMatch = $code{$ItHOrder}{uses}{$$ItSmb{str}}[$CtMatch];
        if (&PerlTurnsComment (substr($CodePlain,0,$$pMatch{pos}), -debug=>$dbg2)) {
          $debug and printf STDERR "%s. match of symbol %s filtered: %s\n", &MySub,
            $$ItSmb{str}, $$pMatch{instance};
          splice @{$code{$ItHOrder}{uses}{$$ItSmb{str}}}, $CtMatch, 1;
          $CtMatch --;
        }
      }
      # symbol should have at least one validated match, otherwise delete from
      # data structure
      unless ($code{$ItHOrder}{uses}{$$ItSmb{str}} and @{$code{$ItHOrder}{uses}{$$ItSmb{str}}}) {
        delete $code{$ItHOrder}{uses}{$$ItSmb{str}};
      }
      # any explicit symbol usage includes implicit package usage
      if (grep { $_ ne $package } keys %{$code{$ItHOrder}{uses}}) {
        $code{$ItHOrder}{uses}{$package} ||= [ 'implicit use' ];
      }
    }
  }

  # load debug
  if ($debug) {
    printf STDERR "%s. symbol usage in extra pieces of code:\n", &MySub;
    $CodeSkipped and
    printf STDERR "  skipped code passage of %d lines, %d chars\n", &MatchCt (\$CodeSkipped, '\n'), length ($CodeSkipped);
    &DataPrint (\%code, -handle=>\*STDERR);
  }

  ##############################################################################
  # report dependencies

  # table header
  printf "# column labels:\n# %s\n", join ("\t",
    qw(module profiting_code imports explic_imp uses extra misses uses_list misses_list));

  # loop over extra code pieces sharing symbols with module
  foreach $ItHOrder (keys %code) {
    unless (int(@{$code{$ItHOrder}{imports}}) or int(keys %{$code{$ItHOrder}{uses}})) {
      next;
    }

    # missing symbols
    $code{$ItHOrder}{misses} = [
      grep { ! $code{$ItHOrder}{ImportIdx}{$_} }
      keys %{$code{$ItHOrder}{uses}} ];

    # extra symbols
    $code{$ItHOrder}{extra} = [
      grep { !exists($code{$ItHOrder}{uses}{$_}) or !int(@{$code{$ItHOrder}{uses}{$_}}) }
      @{$code{$ItHOrder}{imports}} ];

    # output line
    printf "%s\t%s\t%d\t%d\t%d\t%d\t%d\t%s\t%s\n", $PathMod, $code{$ItHOrder}{path},
      int @{$code{$ItHOrder}{imports}},
      $code{$ItHOrder}{explic_imp},
      int keys %{$code{$ItHOrder}{uses}},
      int @{$code{$ItHOrder}{extra}},
      int @{$code{$ItHOrder}{misses}},
      join (' ', sort { ($b eq $package)<=>($a eq $package) or $a cmp $b; } keys %{$code{$ItHOrder}{uses}}),
      join (' ', @{$code{$ItHOrder}{misses}}),
      ;
  }
}


# check comment status for piece of perl code
#
# INTERFACE
# - argument 1: string containing perl code
#
# - options:
#   -debug      [STD]
#
# - return val: boolean for: code has comment status at end of string
#
# DESCRIPTION
# - aspects of detecting a true comment situation:
#   - beware of '#' inside strings
#   - beware of '#' inside regular expressions
#   - we cannot do validation of occurrences inside inline strings (syntax
#     'blabla = <<END_INLINE;\n$smb1\n$smb2\nEND_INLINE\n'. These occurrences
#     validated on the assumption that lines represent executable code
#
sub PerlTurnsComment {
  my ($sPerl, %opt) = @_;
  my ($debug);
  my (@StrSplit, $StrWas, $CharCurr);
  my (%action);

  # function parameters
  $debug = $opt{-debug};

  # prepare string of code
  # currently, work with last line only
  if ($sPerl =~ m/[\s\S\n]*\n/m) {
    $sPerl = $';
  }
  @StrSplit = split (//, $sPerl);
  $debug and printf STDERR "%s. checking code string:\n  %s\n  %d chars\n", &MySub,
    $sPerl||"''", int @StrSplit;

  # sub-calls for extraordinary code status situations
  $action{string} = sub {
    my ($StrChar) = @_;
    # search for end of string
    while ($CharCurr = shift @StrSplit) {
      if ($CharCurr eq $StrChar and substr($StrWas,-1,1) ne '\\') { return }
    }
    $StrWas .= $CharCurr;
  };
  $action{regexp} = sub {
    my ($StrChar) = @_;
    # search for end of string
    while ($CharCurr = shift @StrSplit) {
      if ($CharCurr eq $StrChar and substr($StrWas,-1,1) ne '\\') { return }
    }
    $StrWas .= $CharCurr;
  };

  # successively work through string
  while ($CharCurr = shift @StrSplit) {

    # moving into comment
    # - return TRUE
    # - BUT: we may be inside a regexp here!
    if ($CharCurr eq "#") {

      # or are we inside a regexp here?
      # - skip it (see called action)
      # - restart scan process
      if ($StrWas =~ m/[!=]~ *(s|m|tr)([\/\|\#])/) {
        $debug and printf STDERR "%s. found regexp statement, starting: '%s'\n", &MySub, $&;
        undef $StrWas;
        unshift @StrSplit, split (//, $');
        &{$action{regexp}} ($2);
        $debug and printf STDERR "%s. skipped regexp statement, continuing with: '%s'\n", &MySub, join '', @StrSplit;
        undef $StrWas;
        next;
      }

      # true comment
      return 1;
    }

    # moving over line feed
    if ($CharCurr eq "\n") {
      undef $StrWas;
      next;
    }

    # moving into string statement
    # do neutral move there
    if (($CharCurr eq "'" or $CharCurr eq '"') and substr ($StrWas, -1, 1) ne '\\') {

      # or are we inside a regexp here?
      # - skip it (see called action)
      # - restart scan process
      if ($StrWas =~ m/[!=]~ *(s|m|tr)([\/\|\#])/) {
        $debug and printf STDERR "%s. found regexp statement, starting: '%s'\n", &MySub, $&;
        undef $StrWas;
        unshift @StrSplit, split (//, $');
        &{$action{regexp}} ($2);
        $debug and printf STDERR "%s. skipped regexp statement, continuing with: '%s'\n", &MySub, join '', @StrSplit;
        undef $StrWas;
        next;
      }

      # true string statement
      &{$action{string}} ($CharCurr);
      undef $StrWas;
      $debug and printf STDERR "%s. skipped string statement, continuing with: '%s'\n", &MySub, join '', @StrSplit;
    }

    # we need done string to:
    # - check for recent '\'
    # - recent regexp statement offset
    $StrWas .= $CharCurr;
  }

  # code has not turned comment
  return 0;
}


################################################################################
# miscellaneous functions
################################################################################


# list dicty Baylor reads which are missing as Sample files
#
# INTERFACE
# - global options:
#   -debug      print debug protocol to STDERR
#
# DESCRIPTION
# - do comparison between read index under /gen/bull/raw/*/*/.read_names/*all*
#   and the read names in fastA file $CorePath{GSCJ}{DictyBaylor}.
#
sub ProgBaylorMiss {
  my ($debug, $dbg2);
  my (@ListLib, $ItLib, $file, %RawIdx, $pRead, $ItRead);

  # function parameters
  $debug = $ProgOpt{-debug} || 1;
  $dbg2  = $debug ? $debug-1 : undef;
  @ListLib = qw(IIA IIC);

  # load REAP indices
  foreach $ItLib (@ListLib) {
    $file = "$CorePath{ReadWatch}{RawGroupDir}/$ItLib/$CorePath{GSCJ}{RawReapSub}/$ItLib$CorePath{GSCJ}{RawReapList}";
    unless (defined ($RawIdx{$ItLib} = &PlainToTable ($file,
      -TabType=>'HIA', -ColIdx=>'2', -delimit=>'SpaceRet', -debug=>$dbg2))) {
      printf STDERR "ERROR: no REAP index found for target %s\n", $ItLib||"''";
      exit 1;
    }
    $debug and printf STDERR "%s. %d entries in REAP index file %s\n", &MySub, int keys %{$RawIdx{$ItLib}}, $file;
  }

  # get list of read names
  unless (($pRead = &PlainToTable ("$CorePath{call}{SeqID} $CorePath{GSCJ}{DictyBaylor} |", -TabType=>'A1')) and @$pRead) {
    printf STDERR "ERROR: unable to get list of read names from file %s\n", $CorePath{GSCJ}{DictyBaylor};
    exit 1;
  }
  $debug and printf STDERR "%s. %d read names in file %s\n", &MySub, int @$pRead, $CorePath{GSCJ}{DictyBaylor};

  # search items in index and output missings
  foreach $ItRead (@$pRead) {
    unless (grep {$_} map { $RawIdx{$_}{$ItRead} } @ListLib) {
      print  "$ItRead\n";
    }
  }
}


# memory-swallowing endless loop
#
sub ProgMemOflow {

  # endless loop - increase memory space exponentially
  my @mem = ('AAAAAAAAATGATAAAAATAATGACCTGGAATTGCCAAGGTTGCTCAACAATCAAAAGCATGAATCAGACAAAAAATACAATTAACCTAATAAAACCTGATATATCAATACTAACAGAACCAAATCTAAAAAAGGATCAAAATCTAGCGCAAATCAAAAACCATTACTCAACAGGAGGAAAAGGAAAAGAAGCAAGAGGAAAAGGAGTAATGGCAATAAATCACCTAGAACAAATAGAAATTAAAAACTTGGAAGAAAAAGAAGGCAGAATCTTAAAATTTACTGCAATTCTAAACAATATGGAAATCAACATAATTTGCATCTATGCACCAGCCTCATATGACAGAAGAAAAGGATGGTTTTCAAACAATATTTCCCTTGAAGATCTAGAACAGGCAGACATAGTTACTGGTGACTTTAACATCAACAAATATGCAAAAATCAAGTTCAAAGATGGATCATCCGATAAGAGAAAATTCACAGAAAATGAAACAATAGAATTCCTAATGATGGAAGTAGGACTCACCGAAATACTACCAAATTCAACAACTAAAACAACCTTCAAAGATAAACTAATCGATAGAACATTCTTATCAACAAAGATGCACCAACTCAATCACTCGTACAAGATAATCGATAAAATAAACAAATCAGACCATAACATAGTAGTGATGGATTTCAAAATACCAAATTTCACAAAAATATACAAATCACCCCTATGGAAAATGAACTCAATAATAATTAAAGAAGATAAAACAATAAAAAAGATAGAAAAAATAATCGACCACTACCAGGAAACCAAAAGAAAAAACATTAACATAACGGAATACTGGATTAAGTTCAAAAAAAAAATAAAAAAACAATGCATTACAACAGAAAAGAAAAGAATACTAGAGAGAAAAAAAACGCTATCAAATCTAGCAAATGAACACACAAAAACAAAAAACAAATATGAAAAAGAAACAATATCGAACGAAATAACAATACTTCAAGAAGAAGAAAGAATAGACAGAATGATCAAAAGCTCAATCAACTACATCAACAATAAAGAAATAGCATCAAATCTCCTTACATCTATTCTTAAAAAAAGAGACTCGAGCTCCCAGATTCACAGAATAAAGAACCCATCCAATGGAGAAATCGAAACAGAACAAAAAGAAATAACAGATTGCTTCAGAAAATATTACGAGACACTCTTCAAAGAGAAAGAATGCGACCAAGAAACACATACAGAACTTCTAAGCACCTGGAACCCACCAATAGATAAAAAAAAATTAACAGAGATGGAAGACAGAATCGAAGAATATGAGGTTAAGCTAGCAATAGAAAAGATAGCAGAAGGTAAATCACCAGGAGAAGATGGAATAACATCTTCATTCTATAAAATCCACCAACACAAACTAATTCCAATCCTCACAGAACTATTCAACTTCTTTTTAAACAATGAAATTCCAACAGAATTCAAGAACGGTATCCTTACATCAATATACAAAGGTAAAGGGGATGTCTTGGAAATCTCAAACAGAAGACCAATAACGTTACTCAACGTAGACTACAAAATCTACTCAAAAATAATCAACAATAGAATACTAAAAATCCTGCCAAACATAATCTCAAAGTACCAGAACGGTTTTATACCAGGAAGGCTACTCCACAACAACATTATAGCTTTGGATTTAGCAATGGAAAAGAGTGATAGAAACACGATAATCACCTTTTATGACTTCGAAAAAGCCTTCGATTCAATATCTCATAAAGCGTTAATAAGGACTCTAAACCATCTAAAGTTCCCTCGGAAAATAACAAACACAATACTAAGCATGTTAACGAACACCAACATAAGGGTCATGGTAAATGGACAACTCTCTGAATCCTTCAGAGCAGGAAGAGGTACAAAACAGGGCGACCCAATTTCACCAACTCTCTTCGCTATAGTATGTGAATGCTTATCAACATCAATAAGAAAAGACAATACCATAATAGGCATAAAACTCAATCAGAACAATTCGATGAAGATTGGACAATATGCAGACGACACAGTCACACTAGCCAGTAACATAGATGACGCAGATAAAATGGATATGAAAGTTATAAAATTTTGCCAAGCCACAGCAGCAAAAATAAACGATAATAAATGTGTGTGCATCACTAAAAACCCAAAGATAAAGACCAAATATAAGACAATTGGGGCGAAAGAAGAAGAAAGATATCTTGGCTTTTTCTTCAACCGCAAAGGTGTAATAAGCAAAGTAGATGATACGGTGAACAAACTGGAAAACCTCACAAAATGCTATTCGAGCGTGTCATCAACGCTAAAAGGTAGAATCACAATCCTCAAATCATACCTGCTGTCCCAACTAACATTCCAACTATACATCAACGAAATAAATGACATAAAGAAACTGGAGAACGTTAATGCCAACATGTTATTCAAAGGGGACAGGTGGGCTATCTCAAAAGAAAGGAGCAGAAGAGACTATGAAATTGGAGGCCTGGAACTCTGGAATATGGCAACCAGATCCAATGCCCAGAAAGCATGGATATACGAACAATACCTCAGAGAAAAAGACGACCAGAACTGCCCTCCACATATGGAAGTCTGGAAGTCGGAAAAAGAAAACTCACTATCAAGGATTCACATCAAATGCTGGAAAGCCTGGAAGTTGTTGCACCACCCAAGAGAGCGAATAACTCTCAAACTAAACCAAGTCAAACCCAAATACGAAAACAAACAAAAATTAAAAGTAATCTATAGAAACATGATGGATATCAAATACAAGGGATGGAACAAACACCAGCCAACAACAGGTCAAAAACTGATTCAAAAGAACATTAATCACCCAATTCTACCATTCAGAGAAGCCAGATCAATCACAACTATCAAAGGAAGAGACTTAGCATGGAGATATCTACTCAAGGCACTTCCAAAACACCATGGGGAGAATTGCCACTCATGTAAAGAAGAAGAATCGTCTATGCACATCTTCTTCGAATGCAAATCAATAAAACAGAATATCGACTCAATCTATCAAAAGGTCTGTAAAGACTCCAACAACACTTACCACGGTCCATGGAGCGAAAAAGTTCTCGGAAAACTACTCACACCATTCTCATCAAATCTGATAGGAGCCATTATGGAATCGATATGGTACAGAAGAAATCAAATAAAATTCAACGATAACACTACAATAATAACAGAGAACCAAATAATTCATAAAATCAAAAAAGCGAGAGATGCCGAATGGGATAGACCAAGAAAGATAGTAGAAAAACAACTACGTCAAGAACTAAGATGCACTGATAACCGAGAGTCAATCAATCGGACCGCATCAATAAAAAGAAGACTCGAAAAATTCAGCCACAACTGGAACTCGAAACTCATGACCATAAACATCCCGGAACACTTCATACCATACTGCTCATATAACACCAACTACTCATAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAATTATAACAATAATAATAATAATAATAATATAATAATAATAATAATATAATAATAATAATATAATAATAATAATAATATAATAATAATAATAATAAAAAAAAAAATAAGAATACCAAGAAAAAAGGAAAAAAAAAAA');
  while (1) {
    push @mem, @mem;
  }
}


# round number
#
sub ProgRound {
  require Math::Round; Math::Round->import('&nearest');
  my ($num, $step) = @_;
  $step ||= 1;

  # function parameters
  if ($num eq '-') {
    $num = &ReadFile (\*STDIN);
  }

  # calculate and output
  printf "%s\n", &nearest($step,$num);
}

# $Id: Misc.pl,v 1.36 2018/06/05 18:02:56 szafrans Exp $
