################################################################################
#
#  kPerl Core Library Group
#  Object Library for Management of Temporary Files
#
#  copyright (c)
#    Karol Szafranski, 2004, 2006
#    Institute of Molecular Biotechnology Jena, Dept. Genome Analysis, 2004
#  author
#    Karol Szafranski, karol.szafranski@leibniz-fli.de
#
################################################################################
#
#  DESCRIPTION
#
# - purpose:
#   This class manages creation, deletion, and persistence of temporary
#   files. An object is initialized with path stump information and a counting
#   rule which will be used to create new filenames. Subsequently, using
#   method Create() one can request non-existent filenames based on the
#   naming rules. Upon destruction of the object, all files linked to the
#   naming rules will be deleted (unless explicitly prevented by the caller).
#
#   The object will not keep track of the suggested filenames. It will just
#   suggest new non-existent filenames.
#
# - recommended usage:
#   create an object at the beginning of the program or package
#
#     # main program
#     use MainLib::FileTmp;
#     our $pTmpManag = MainLib::FileTmp->new(
#       -template=>( (split('/',__FILE__))[-1] =~ m/(\w+)/ )[0].'.tmp'
#       );
#
#     # library package
#     use MainLib::FileTmp;
#     our $pTmpManag = MainLib::FileTmp->new(
#       -template=>(split('::',__PACKAGE__))[-1].'.tmp'
#       );
#
# - dependencies:
#   - Some aspects of the implementation are specific for UNIX/Linux systems.
#
# - individual description of functions can be found at the beginning of the
#   code blocks
#
################################################################################
#
#  OBJECT OPERATORS
#
#   *** NONE ***
#
#
#  OBJECT METHODS  for external access
#
#   new           create object, initialize via ini(%opt)
#   AddSwitch     render object options
#   Create        return filename for new temporary file
#                 wantarray: return array of filename and output FileHandle
#                 By default, the temporary file is not created, cmp. switch
#                 -touch.
#   CreateGrp     initialize group of temporary files that are all derived
#                 from the same base filename by appending a unique file suffix.
#
#
#  OBJECT DATA STRUCTURE
#  (hash)
#
#   caller        calling package. This identity contributes to the default
#                 filename template string
#   dir           directory path
#   fcount        count of created temporary files
#   glob          glob statement to match created temporary files
#   switch        hash reference for object switches, cf. method AddSwitch()
#    -countset      character set for counting to uniqueness (option -CtSet
#                   to &MainLib::File::PathUnique), default: numeric count.
#    -dir           directory path, default $ENV{TEMPPATH} or "/tmp"
#                   (determined via &MainLib::File::PathTmpdir)
#    -debug         print debug protocol to STDERR
#    -preserve      preserve temporary files beyond object life time
#    -suffix        use suffix in filename template for temporary files,
#                   argument "" says to omit any suffix from the filename
#                   template for temporary files
#    -template      provide full filename template for temporary files
#    -touch         instantaneously create requested temporary files (with
#                   null length)
#   template      reference to array of temporary files
#
################################################################################
#
#  FUNCTIONS, DATA
#
#   @EXPORT_OK
#   @ISA
#
# - housekeeping
#   &new  see MainLib::DefaultObjHash
#   &ini
#   &AddSwitch
#   &_LocalSwitch  see MainLib::DefaultObjHash
#   &Create
#   &CreateGrp
#   &DESTROY
#
# - non-method functions
#   &PathTmpdir
#   &PathUnique
#
# - package MainLib::FileTmpGrp;
#   &new
#   &_LocalSwitch  see MainLib::DefaultObjHash
#   &Create
#   &DESTROY
#
#
#  STD OPTIONS
#
#  -debug      print debug protocol to STDERR
#
################################################################################

package MainLib::FileTmp;

# includes
use strict; #use warnings;  # OK 20040825
use File::Basename;
use MainLib::DefaultObjHash;
###
  # &MainLib::Data::DataClone, when working on an object, queries it for
  # having a DataClone() method, assumed to represent an object-specific
  # DataClone implementation, and will call it.  We cannot import the function
  # symbol since this subpropagation mechanism would cause an endless loop!
use MainLib::Path qw(&PathExpand);
use MainLib::File qw(&ReadDir &touch);
use MainLib::Misc qw(&MySub);
use Math::kCalc qw(&Sum);

# symbol export
# - only for non-method functions
# - no default export
use Exporter qw(import);
our @EXPORT_OK = qw (&PathTmpdir &PathUnique);

# inheritance
our @ISA;
push @ISA, qw(MainLib::DefaultObjHash);


################################################################################
# housekeeping
################################################################################


# parametric initialization
#
# INTERFACE
# - options:
#   All object switches (cf. "DESCRIPTION"). The following list contains options
#   useful for object initialization:
#   -dir        directory for temporary files, default determined from
#               &MainLib::Path::PathTmpdir().
#   -suffix     use suffix in filename template for temporary files
#   -template   full filename template for temporary files, default: see
#               AddSwitch(). If the name template includes a directory path it
#               will have the same effect as if specified as (-dir=>$dir).
#               However, any explicit statement of (-dir=>$dir) will get
#               prevalence.
#
# - return val: - object reference
#               - undef if an error occured
#
sub ini {
  my ($this,%opt) = @_;
  my $debug = $this->{switch}{-debug} || $opt{-debug};

  # initialize existing object
  # -  this is deprecated way of usage
  # => DESTROY() existing object, continue as with new object
  my $CallerNum;
  if ($debug) {
    printf STDERR "%s. calling hierarchy:\n", &MySub;
    print  STDERR
      map{ sprintf("  %d -> \"%s\"\n",$_,(caller($_))[3]||'') }
      grep{ (caller($_))[0] } 0..3;
  }
  if ((caller(1))[3] ne 'MainLib::DefaultObjHash::new') {
    $this->DESTROY();
    $CallerNum = 1;
  }
  # this got called via package->new()
  else {
    $CallerNum = 2;
  }
  %$this = ();

  # remind initialising caller package
  $this->{caller} = (caller($CallerNum))[0];
  if (!$this->{caller} or $this->{caller} eq 'main') {
    my $CallerStump = ( split('/',$0) )[-1];
    $CallerStump =~ s/\.\w{1,4}$//;
    $this->{caller} = $CallerStump;
  }

  # enter object switches, update object attributes
  $this->AddSwitch(%opt) or return undef;

  # return
  return $this;
}


# enter object switches, update object attributes
#
# INTERFACE
# - argument 1*: hash of switches
# - return val:  success status (boolean)
#
# DESCRIPTION
# - for description of object switches see very top of the module
#
sub AddSwitch {
  my ($this,%oopt) = @_;
  my $debug = $this->{switch}{-debug} || $oopt{-debug};

  # loop over switches
  my $bErr;
  while (my($key,$val) = each(%oopt)) {
    if (0) {}

    elsif (
      $key=~m/-(dir|suffix|template)/ and
      defined($val) and $this->{fcount}
    ) {
      $bErr = 1;
      printf STDERR "%s. ERROR: filename template re-definitions not allowed after creation of temporary files\n", &MySub;
    }

    elsif ($key eq '-template' and $val=~m|^(.*)/|) {
      $oopt{dir} ||= $1;
      $this->{switch}{$key} = $';
    }

    #options that we just have to enter
    else {
      if (defined $val) { $this->{switch}{$key} = $val; }
      else       { delete $this->{switch}{$key}; }
    }
  }

  # update object attributes
  if (! $bErr) {

    # create filename template
    $this->{dir} = $this->{switch}{-dir} || &PathTmpdir();
    my $CallerStump = ( split(/::/,$this->{caller}||'') )[-1];
    my $suffix = defined($this->{switch}{-suffix}) ? $this->{switch}{-suffix} : 'tmp';
    $this->{template} = $this->{switch}{-template}
      || sprintf('%d_%s_#%s%s',$$,$CallerStump,length($suffix)?'.':'',$suffix);

    # derive filename glob from filename template
    # - the following is repetition of the numbering field definition as
    #   implemented in &PathUnique
    $this->{glob} = $this->{template};
    my $bChg = $this->{glob} =~ s/^(.*[^#]|^)#+/$1*/;
    $bChg ||= $this->{glob} =~ s/^(.*)\./$1*./;
    $bChg or $this->{glob} .= '*';
    $this->{glob} = $this->{dir} .'/'. $this->{glob};

    # debug
    if ($debug) {
      require MainLib::Data; MainLib::Data->import('&DataPrint');
      my $d = $this;
      if (exists ($d->{switch}{-countset})) {
        $d = &MainLib::Data::DataClone ({%$this}, -debug=>($debug?$debug-1:undef));
        $d->{switch}{-countset} =
          sprintf('ARRAY_of_%d_entries',int(@{$d->{switch}{-countset}||[]}));
      }
      printf STDERR "%s. how i look like:\n", &MySub;
      &DataPrint ($d, -handle=>\*STDERR, -space=>2);
    }
  }

  # return success status
  return !$bErr;
}


# find filename for next non-existent temporary file
#
# INTERFACE
# - options:
#   -debug      [STD]
#   -touch      create file (with null length)
#
# - return val: - wantscalar: filename
#               - wantarray: filename, FileHandle
#
sub Create {
  my ($this,%opt) = @_;
  my %lopt = $this->_LocalSwitch(%opt);

  # find filename
  my $fname = &PathUnique (-name=>$this->{template}, -dir=>$this->{dir},
    -CtSet=>$this->{switch}{-countset}, -touch=>$lopt{-touch},
    -debug=>$lopt{-debug});

  # count returned filenames
  ($this->{fcount}||=0) ++;

  # create filehandle?
  if (wantarray) {
    require FileHandle;
    return ($fname, FileHandle->new($fname,'w'));
  } else {
    return $fname;
  }
}


# create file group starting with non-existent temporary file
#
# INTERFACE
# - options:
#   -debug      [STD]
#   -touch      create all group files with null length
#
# - return val: reference to group object
#
# DESCRIPTION
# - all group members will be derived from the base filename by appending a
#   unique file suffix.
# - destruction of the object will automatically release all temporary files
#
sub CreateGrp {
  my ($this,%opt) = @_;

  # unique filename (stump)
  my $fname = &Create(@_,-touch=>1);
  # create group object
  return MainLib::FileTmpGrp->new ($fname, %{$this->{switch}},
    -dir => undef, %opt);
}


# destroy object
#
sub DESTROY {
  my ($this) = @_;
  my $bPreserve = $this->{switch}{-debug} || $this->{switch}{-preserve};

  # determine any existing temporary files (@left) and directories (@leftdir)
  my (@left,$dir,@leftdir);
  if ($this->{fcount}) {
    @left = glob ($this->{glob});
    for (my $ct=0; $ct<int(@left); ++$ct) {
      -d ($dir=$left[$ct]) or next;
      push @leftdir, splice(@left,$ct,1);
      push @left, &ReadDir($dir,-expand=>1);
      $ct --;
    }

    # delete any existing temporary files and directories
    if ((@left or @leftdir) and !$bPreserve) {
      unlink @left;
      foreach (@leftdir) { rmdir($_) }
    }

    # temporary files that remain?
    @left = glob ($this->{glob});
    # resolve directories to files contained therein
    # - subdirectories are not futher resolved
    for (my $ct=0; $ct<int(@left); ++$ct) {
      -d ($dir=$left[$ct]) or next;
      push @left, &ReadDir($dir,-expand=>1);
    }
    if (@left) {
      printf STDERR "WARNING: %d tmp file%s left as %s , using %d byte\n",
        int(@left), ($this->{fcount}==1) ? '':'s',
        $this->{glob}, &Sum(map{ -s($_) }@left);
    }
  }
}


################################################################################
# non-method functions
################################################################################


# return path of temporary directory
#
# INTERFACE
# - return val: - temporary directory path, string without trailing slash
#               - undef if an error occurred
#
sub PathTmpdir {
  my ($PathTmpdir);

  # determine path, confirm existence
  $PathTmpdir = (grep { $_ and -d $_ }
    $ENV{TEMPPATH}, "$ENV{HOME}/tmp", "$ENV{HOME}/temp", '/tmp'
    )[0];
  unless ($PathTmpdir and -d $PathTmpdir) {
    die sprintf "%s. ERROR: unable to determine temporary directory\n", &MySub;
  }
  unless (-w $PathTmpdir) {
    die sprintf "%s. WARNING: no write permission on temporary directory %s\n", &MySub, $PathTmpdir;
  }

  # expand path
  $PathTmpdir = &PathExpand($PathTmpdir);

  # exit SUB
  return $PathTmpdir;
}


# work out unique file path
#
# INTERFACE
# - options:
#   -CtHex       counting phrase is upper case hexadecimal instead of arabic
#                number (default). Option is simply set by true value.
#   -CtHexL      counting phrase is lower case hexadecimal, cf. -CtHex.
#   -CtSet       compose counting phrase from specified set of characters
#   -CtStart     start value for uniqueness counter (default: 0)
#   -debug       [STD]
#   -dir         use specified directory path, default $ENV{TEMPPATH}.  This
#                option overrides any directory specified along with option
#                -name.
#   -HotField    Sets field range character for introduction of counting phrase.
#                Default character is '#'. In case of multiple occurrence of
#                hot fields the last field will be used.
#                The digit field of the resulting filename will have at least
#                as much characters as the hot field in the '-name' option if
#                the '-NoSize' option is not set. Setting a '-HotField' option
#                without setting the '-name' option produces senseless but
#                valid return.
#                If no counting field is included in the name template,
#                counting digits will be introduced before the last '.' in the
#                template (if present) or at the end of the template phrase (no
#                '.' character present). Then, the function behaves like the
#                '-NoSize' option being set.
#   -name        template phrase for filename, default 'kUnique###.tmp'. See
#                also '-HotField:X' option. A directory component, specified
#                here, will have the same effect as option -dir.
#   -NoSize      Although a hot field is marked in the string of the -name
#                option, the field is not filled with zero digits to fit the
#                field size. The option is simply set by true value. You'll
#                need to use this option if you want to direct the counter
#                position, but you prefer counter-free path names.
#   -touch       generate a file for the filename that's worked out. This
#                option prevents the occurring that a unique path will be
#                returned a second time because the file isn't generated yet.
#
# - return val:  - requested nonexisting unique file path
#                - undef if an error occurred.
#
sub PathUnique {
  my $TplName = 'kUnique###.tmp';
  my (%opt) = @_;
  my $debug = $opt{-debug};

  my ($TplDir,$TplNameOff,$TplNameEnd);

  # work out name phrase to be used
  # if the -name option contains a directory path => extract it anyhow
  #   It'll be used unless switch -dir overrides the value
  if ($opt{-name}) {
    $debug and printf STDERR "%s. got primary filename template: %s\n", &MySub, $opt{-name}||"''";
    $TplDir = &dirname($opt{-name});
    $TplName = &basename($opt{-name});
    $TplDir =~ s/^\.$//;
    if ($debug and $TplDir) {
      printf STDERR "%s. directory path as got from option -name: %s\n", &MySub, $TplDir||"''";
    }
  }
  # else $TplName is left the default value

  # work out directory path to be used
  # if the -name option did contain a directory path it's now in $TplDir
  if ($opt{-dir}) {
    $TplDir = $opt{-dir};
  } else {
    $TplDir ||= &PathTmpdir();
  }
  if (! -d $TplDir or ! -w $TplDir) { return undef }
  if ($debug) {
    printf STDERR "%s. meanwhile summary:\n", &MySub;
    printf STDERR "  directory path: %s\n", $TplDir||"''";
    printf STDERR "  filename template: %s\n", $TplName||"''";
  }

  # decide where to introduce counting phrase
  # - The base filename is split into pre and end part
  # - $FieldSize is derived from the length of the counting field
  my $FieldChar = ($opt{-HotField}) ? substr($opt{-HotField},0,1) : '#';
  my $FieldSize;
  while ($TplName =~ m/$FieldChar+/g) {
    $TplNameOff = $`;
    $TplNameEnd = $';
    $FieldSize = length($&);
  }
  unless ($FieldSize) {
    $FieldSize = 0;
    while ($TplName =~ m/\./g) {
      $TplNameOff = $`;
      $TplNameEnd = $&.$';
    }
    unless ($TplNameOff) {
      $TplNameOff = $TplName;
      $TplNameEnd = '';
    }
  }
  if ($opt{-NoSize}) { $FieldSize=0 }

  # test until file path is unique
  my $CtSignif = $opt{-CtStart} || 0;
  my ($PhraseSignif,$PathUnique);
  do {
    if ($opt{-CtHex}) {
      $PhraseSignif = sprintf ("%0*X", $FieldSize, $CtSignif);
    } elsif ($opt{-CtHexL}) {
      $PhraseSignif = sprintf ("%0*x", $FieldSize, $CtSignif);
    } elsif ($opt{-CtSet}) {
      require MainLib::StrRegexp; MainLib::StrRegexp->import('&packWX');
      $PhraseSignif = &packWX ($CtSignif, $opt{-CtSet}, -size=>$FieldSize);
      if (($CtSignif||$FieldSize) and !length($PhraseSignif)) {
        die sprintf "%s. ERROR: &packWX failed, probably wrong arg to option -CtSet\n", &MySub;
      }
    } elsif ($FieldSize) {
      $PhraseSignif = sprintf ("%0*d", $FieldSize, $CtSignif);
    } else {
      $PhraseSignif = $CtSignif ? "$CtSignif" : '';
    }
    $PathUnique = "$TplDir/$TplNameOff$PhraseSignif$TplNameEnd";
    $CtSignif ++;
  } while (-e $PathUnique);

  # optionally generate file for the derived filename
  $debug and printf STDERR "%s. returning path: %s\n", &MySub, $PathUnique||"''";
  if ($opt{-touch}) { &touch($PathUnique) }

  # exit
  return $PathUnique;
}


################################################################################
package MainLib::FileTmpGrp;

# includes
use strict; #use warnings;  # OK 20060602
use MainLib::DefaultObjHash;

# inheritance
our @ISA;
push @ISA, qw(MainLib::DefaultObjHash);


# construct object
#
sub new {
  my (undef,$basename,%opt) = @_;
  my $this = bless {
    switch => { %opt },
    base => $basename,
    file => { ''=>1 }
    };

  # debug
  if ($opt{-debug}) {
    require MainLib::Data; MainLib::Data->import('&DataPrint');
    printf STDERR "%s. how i look like:\n", (caller(0))[3];
    &DataPrint ($this, -handle=>\*STDERR, -space=>2);
  }
  return $this;
}


# derive file
#
sub Create {
  my ($this,$sfx,%opt) = @_;
  my %lopt = $this->_LocalSwitch(%opt);

  # register suffix
  $this->{file}{$sfx} = 1;
  # derive filename from base and suffix
  my $fname = $this->{base} . $sfx;
  $lopt{-debug} and printf STDERR "%s. adding file %s\n", (caller(0))[3], $fname;
  if (-e $fname and !$lopt{-silent}) {
     printf STDERR "%s. WARNING: file already exists %s\n", (caller(0))[3], $fname;
  }

  # optionally generate file for the derived filename
  if ($lopt{-touch}) { &touch($fname) }
  return $fname;
}


# destroy object
#
sub DESTROY {
  my ($this) = @_;
  my $debug = $this->{switch}{-debug};
  my $bPreserve = $this->{switch}{-debug} || $this->{switch}{-preserve};

  # delete files belonging to the group
  if (!$bPreserve) {
    foreach (keys %{$this->{file}}) {
      unlink ($this->{base}.$_);
      $debug and printf STDERR "%s. unlinking file %s\n", (caller(0))[3], $this->{base}.$_;
    }
  }
}


1;
# $Id: FileTmp.pm,v 1.20 2018/06/05 18:02:56 szafrans Exp $
