path: root/Master/tlpkg/TeXLive/TLPOBJ.pm

#
# TeXLive::TLPOBJ.pm
# module for using tlpobj files
# Copyright 2007 Norbert Preining
#
# This file is licensed under the GNU General Public Licence version 2
# or any later version

package TeXLive::TLPOBJ;

use TeXLive::TLUtils;
use File::Path;
use Cwd;
use TeXLive::TLTREE;
use FileHandle;

my $_tmp;
my $_zipdir;

sub new { 
  my $class = shift;
  my %params = @_;
  my $self = {
    name        => $params{'name'},
    category    => defined($params{'category'}) ? $params{'category'} : "Package",
    shortdesc   => $params{'shortdesc'},
    longdesc    => $params{'longdesc'},
    catalogue   => $params{'catalogue'},
    runfiles    => defined($params{'runfiles'}) ? $params{'runfiles'} : [],
    runsize   => $params{'runsize'},
    srcfiles    => defined($params{'srcfiles'}) ? $params{'srcfiles'} : [],
    srcsize   => $params{'srcsize'},
    docfiles    => defined($params{'docfiles'}) ? $params{'docfiles'} : [],
    docsize   => $params{'docsize'},
    executes    => defined($params{'executes'}) ? $params{'executes'} : [],
    # note that binfiles is an ARRAY with keys of $arch!
    binfiles    => defined($params{'binfiles'}) ? $params{'binfiles'} : {},
    binsize     => defined($params{'binsize'}) ? $params{'binsize'} : {},
    depends     => defined($params{'depends'}) ? $params{'depends'} : [],
    revision    => $params{'revision'},
  };
  $_zipdir = $params{'zipdir'} if defined($params{'zipdir'});
  bless $self, $class;
  return $self;
}

sub from_file {
  my $self = shift;
  if (@_ != 1) {
    die("Need a filename for initialization!");
  }
  open(TMP,"<$_[0]") || die("Cannot open tlpobj file: $_[0]");
  $self->from_fh(\*TMP);
}
  
sub from_fh {
  my ($self,$fh,$multi) = @_;
  my $started = 0;
  my $lastcmd = "";
  my $arch;
  my $size;

  while (my $line = $fh->getline) {
    &TeXLive::TLUtils::debug("reading line: >>>$line<<<\n");
    &TeXLive::TLUtils::debug("multi=...$multi...\n");
    $line =~ /^\s*#/ && next;          # skip comment lines
    if ($line =~ /^\s*$/) {
      if (!$started) { next; }
      if (defined($multi)) {
        # we may read from a tldb file
        return 1;
      } else {
        # we are reading one tldb file, nothing else allowed
        die("No empty line allowed within tlpobj files!");
      }
    }
    if ($line =~ /^ /) {
      if ( ($lastcmd eq "longdesc") ||
           ($lastcmd eq "runfiles")  ||
           ($lastcmd eq "binfiles")  ||
           ($lastcmd eq "docfiles")  ||
           ($lastcmd eq "srcfiles")  ||
           ($lastcmd eq "executes")  ||
         ($lastcmd eq "depend") ) {
        $line =~ s/^ /${lastcmd}continued /;
      } else {
        die("Continuation of $lastcmd not allowed, please fix tlpobj!\n");
      }
    }
    if ($line =~ /^name\s*([-\w]+)$/) {
      $name = "$1";
      $lastcmd = "name";
      $self->name("$name");
      $started && die("Cannot have two name directives: $line!");
      $started = 1;
    } else {
      $started || die("First directive needs to be 'name'");
      if ($line =~ /^shortdesc\s+(.*)$/) {
        $self->{'shortdesc'} .= "$1";
        $lastcmd = "shortdesc";
        next;
      } elsif ($line =~ /^longdesc(continued)?\s+(.*)$/) {
        if (defined($1) && ("$1" eq "continued")) {
          $self->{'longdesc'} .= " $2";
        } else {
          $self->{'longdesc'} = "$2";
        }
        $lastcmd = "longdesc";
        next;
      } elsif ($line =~ /^category\s+(Scheme|Collection|Package|TLCore|Documentation)$/) {
        $self->{'category'} = "$1";
        $lastcmd = "category";
        next;
      } elsif ($line =~ /^revision\s+(.*)$/) {
        $self->{'revision'} = "$1";
        $lastcmd = "revision";
        next;
      } elsif ($line =~ /^catalogue\s+(.*)$/) {
        $self->catalogue("$1");
        $lastcmd = "catalogue";
        next;
      } elsif ($line =~ /^(doc|src|run)files\s+/) {
        my $type = $1;
        my @words = split ' ',$line;
        # first entry is "XXXfiles", shift it away
        $lastcmd = shift @words;
        while (@words) {
          $_ = shift @words;
          if (/^size=(.*)$/) {
            $size=$1;
          } else {
            die "Unknown tag: $line";
          }
        }
        if (defined($size)) {
          $self->{"${type}size"} = $size;
        }
        next;
      } elsif ($line =~ /^(doc|src|run)filescontinued\s+(.*)$/) {
        push @{$self->{$1."files"}}, "$2";
        next;
      } elsif ($line =~ /^binfiles\s+/) {
        my @words = split ' ',$line;
        # first entry is "binfiles", shift it away
        shift @words;
        while (@words) {
          $_ = shift @words;
          if (/^arch=(.*)$/) {
            $arch=$1;
          } elsif (/^size=(.*)$/) {
            $size=$1;
          } else {
            die "Unknown tag: $line";
          }
        }
        if (defined($size)) {
          $self->{'binsize'}{$arch} = $size;
        }
        $lastcmd = "binfiles";
        next;
      } elsif ($line =~ /^binfilescontinued\s+(.*)$/) {
        push @{$self->{'binfiles'}{$arch}}, "$1";
        next;
      } elsif ($line =~ /^execute(continued)?\s*(.*)$/) {
        push @{$self->{'executes'}}, "$2" unless "$2" eq "";
        $lastcmd = "execute";
        next;
      } elsif ($line =~ /^depend(continued)?\s*(.*)$/) {
        push @{$self->{'depends'}}, "$2" unless "$2" eq "";
        $lastcmd = "depend";
        next;
      } else {
        die("Unknown directive ...$line... , please fix it!");
      }
    }
  }
  return $started;
}

sub recompute_revision {
  my ($self,$tltree) = @_;
  my @files;
  foreach my $a (keys %{$self->{'binfiles'}}) {
    push @files, @{$self->{'binfiles'}{$a}};
  }
  push @files, $self->runfiles;
  push @files, $self->docfiles;
  push @files, $self->srcfiles;
  $filemax = 0;
  foreach my $f (@files) {
    $filemax = $tltree->file_svn_lastrevision($f);
    $self->revision(($filemax > $self->revision) ? $filemax : $self->revision);
  }
}

sub recompute_sizes {
  my ($self,$tltree) = @_;
  $self->{'docsize'} = $self->_recompute_size("doc",$tltree);
  $self->{'srcsize'} = $self->_recompute_size("src",$tltree);
  $self->{'runsize'} = $self->_recompute_size("run",$tltree);
  foreach $a ($tltree->architectures) {
    $self->{'binsize'}{$a} = $self->_recompute_size("bin",$tltree,$a);
  }
}


sub _recompute_size {
  my ($self,$type,$tltree,$arch) = @_;
  my $size = 0;
  if ($type eq "bin") {
    my %binfiles = %{$self->{'binfiles'}};
    if (defined($binfiles{$arch})) {
      foreach $f (@{$binfiles{$arch}}) {
        $size += $tltree->size_of($f);
      }
    } 
  } else {
    if (defined($self->{"${type}files"}) && (@{$self->{"${type}files"}})) {
      foreach $f (@{$self->{"${type}files"}}) {
        my $s = $tltree->size_of($f);
        if (defined($s)) {
          $size += $s;
        } else {
          printf STDERR "size for $f not defined, strange ...\n";
        }
      }
    }
  }
  return $size;
}

sub writeout {
  my $self = shift;
  my $fd = (@_ ? $_[0] : STDOUT);
  format_name $fd "multilineformat";
  print $fd "name ", $self->name, "\n";
  print $fd "category ", $self->category, "\n";
  defined($self->{'revision'}) && print $fd "revision $self->{'revision'}\n";
  defined($self->{'catalogue'}) && print $fd "catalogue $self->{'catalogue'}\n";
  defined($self->{'shortdesc'}) && print $fd "shortdesc $self->{'shortdesc'}\n";
  if (defined($self->{'longdesc'})) {
    $_tmp = "$self->{'longdesc'}";
    write $fd;
  }
  if (defined($self->{'depends'})) {
    foreach (@{$self->{'depends'}}) {
      print $fd "depend $_\n";
    }
  }
  if (defined($self->{'executes'})) {
    foreach (@{$self->{'executes'}}) {
      print $fd "execute $_\n";
    }
  }
  if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) {
    print $fd "docfiles size=$self->{'docsize'}\n";
    foreach (sort @{$self->{'docfiles'}}) {
      print $fd " $_\n";
    }
  }
  if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) {
    print $fd "srcfiles size=$self->{'srcsize'}\n";
    foreach (sort @{$self->{'srcfiles'}}) {
      print $fd " $_\n";
    }
  }
  if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) {
    print $fd "runfiles size=$self->{'runsize'}\n";
    foreach (sort @{$self->{'runfiles'}}) {
      print $fd " $_\n";
    }
  }
  foreach my $arch (keys %{$self->{'binfiles'}}) {
    if (@{$self->{'binfiles'}{$arch}}) {
      print $fd "binfiles arch=$arch size=", $self->{'binsize'}{$arch}, "\n";
      foreach (sort @{$self->{'binfiles'}{$arch}}) {
        print $fd " $_\n";
      }
    }
  }
}

sub writeout_simple {
  my $self = shift;
  my $fd = (@_ ? $_[0] : STDOUT);
  format_name $fd "multilineformat";
  print $fd "name ", $self->name, "\n";
  print $fd "category ", $self->category, "\n";
  if (defined($self->{'depends'})) {
    foreach (@{$self->{'depends'}}) {
      print $fd "depend $_\n";
    }
  }
  if (defined($self->{'executes'})) {
    foreach (@{$self->{'executes'}}) {
      print $fd "execute $_\n";
    }
  }
  if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) {
    print $fd "docfiles\n";
    foreach (sort @{$self->{'docfiles'}}) {
      print $fd " $_\n";
    }
  }
  if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) {
    print $fd "srcfiles\n";
    foreach (sort @{$self->{'srcfiles'}}) {
      print $fd " $_\n";
    }
  }
  if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) {
    print $fd "runfiles\n";
    foreach (sort @{$self->{'runfiles'}}) {
      print $fd " $_\n";
    }
  }
  foreach my $arch (sort keys %{$self->{'binfiles'}}) {
    if (@{$self->{'binfiles'}{$arch}}) {
      print $fd "binfiles arch=$arch\n";
      foreach (sort @{$self->{'binfiles'}{$arch}}) {
        print $fd " $_\n";
      }
    }
  }
}


sub make_zip {
  my ($self,$tltree,$destdir,$zipname) = @_;
  my $zipn;
  if (not(defined($zipname))) {
    $zipname = $self->name . ".zip";
  }
  if (not(defined($destdir))) {
    $destdir = TeXLive::TLPOBJ->zipdir;
  }
  die("Undefined tltree argument!") if (not(defined($tltree)));
  # first build the arch independet part
  $self->_make_zip($tltree,$destdir,$zipname,"all");
  # now the $pkg.$arch.zip
  if ($self->is_arch_dependent) {
    foreach my $t (keys %{$self->{'binfiles'}}) {
      &TeXLive::TLUtils::debug("arch=$t\n");
      if ($zipname =~ /^(.*)\.zip$/) {
        $zipn = "$1.$t.zip";
      } else {
        $zipn = "$zipname.$t.zip";
      }
      $self->_make_zip($tltree,$destdir,$zipn,$t);
    }
  }
}

sub _make_zip {
  my ($self,$tltree,$destdir,$zipname,$arch) = @_;
  my $root = $tltree->svnroot;
  my @files = ();
  my $zipcmd;
  if ($arch ne "all") {
    push @files, @{$self->{'binfiles'}{$arch}};
  } else {
    push @files, $self->runfiles;
    push @files, $self->docfiles;
    push @files, $self->srcfiles;
  }
  # note that the Tpm.pm module had something like
  #   if ($zipname =~ /\/binary/ && $^O !~ /MSWin32/) {
  #     $zipcmd = "| zip -9\@ory "
  #   } else {
  #     $zipcmd = "| zip -9\@or "
  #   }
  if ($^O =~ /MSWin32/) {
    $nul = "nul";
    $zipcmd = "| zip -9\@or "
  } else {
    $nul = "/dev/null";
    $zipcmd = "| zip -9\@ory "
  }
  @files = TeXLive::TLUtils::sort_uniq(@files);
  if (!@files) {
    &TeXLive::TLUtils::debug("Not creating empty zip file $zipname\n");
    return;
  }
  &mkpath("$destdir") if (! -d "$destdir");
  my $cwd = &getcwd;
  chdir($tltree->svnroot);
  unlink($zipname);
  print $zipcmd . "$destdir/$zipname" . " > $nul\n" if ($::opt_debug);
  open ZIP, $zipcmd . "$destdir/$zipname" . " > $nul";
  map {
    if (! -f $_) {
      print STDERR "!!!Error: non-existent $_\n";
    } else {
      print ZIP "$_\n";
    }
  } @files;
  close ZIP;
  print "Done $zipname\n" if ($::opt_debug);
}

sub is_arch_dependent {
  my $self = shift;
  if (keys %{$self->{'binfiles'}}) {
    return 1;
  } else {
    return 0;
  }
}

# computes the total size of a package
# if no arguments are given this is
#   docsize + runsize + srcsize + max of binsizes
sub total_size {
  my ($self,@archs) = @_;
  my $ret = $self->docsize + $self->runsize + $self->srcsize;
  if ($self->is_arch_dependent) {
    my $max = 0;
    my %foo = %{$self->binsizes};
    foreach my $k (keys %foo) {
      $max = $foo{$k} if ($foo{$k} > $max);
    }
    $ret += $max;
  }
  return($ret);
}

#
# member access functions
#
sub name {
  my $self = shift;
  if (@_) { $self->{'name'} = shift }
  return $self->{'name'};
}
sub category {
  my $self = shift;
  if (@_) { $self->{'category'} = shift }
  return $self->{'category'};
}
sub shortdesc {
  my $self = shift;
  if (@_) { $self->{'shortdesc'} = shift }
  return $self->{'shortdesc'};
}
sub longdesc {
  my $self = shift;
  if (@_) { $self->{'longdesc'} = shift }
  return $self->{'longdesc'};
}
sub revision {
  my $self = shift;
  if (@_) { $self->{'revision'} = shift }
  return $self->{'revision'};
}
sub catalogue {
  my $self = shift;
  if (@_) { $self->{'catalogue'} = shift }
  return $self->{'catalogue'};
}
sub srcfiles {
  my $self = shift;
  if (@_) { @{ $self->{'srcfiles'} } = @_ }
  return @{ $self->{'srcfiles'} };
}
sub srcsize {
  my $self = shift;
  if (@_) { $self->{'srcsize'} = shift }
  return ( defined($self->{'srcsize'}) ? $self->{'srcsize'} : 0 );
}
sub add_srcfiles {
  my ($self,@files) = @_;
  $self->add_files("src",@files);
}
sub remove_srcfiles {
  my ($self,@files) = @_;
  $self->remove_files("src",@files);
}
sub docfiles {
  my $self = shift;
  if (@_) { @{ $self->{'docfiles'} } = @_ }
  return @{ $self->{'docfiles'} };
}
sub docsize {
  my $self = shift;
  if (@_) { $self->{'docsize'} = shift }
  return ( defined($self->{'docsize'}) ? $self->{'docsize'} : 0 );
}
sub add_docfiles {
  my ($self,@files) = @_;
  $self->add_files("doc",@files);
}
sub remove_docfiles {
  my ($self,@files) = @_;
  $self->remove_files("doc",@files);
}
sub binfiles {
  my $self = shift;
  my %newfiles = @_;
  if (@_) { $self->{'binfiles'} = \%newfiles }
  return $self->{'binfiles'};
}
sub binsizes {
  my $self = shift;
  my %newsizes = @_;
  if (@_) { $self->{'binsizes'} = \%newsizes }
  return $self->{'binsizes'};
}
sub add_binfiles {
  my ($self,$arch,@files) = @_;
  &TeXLive::TLUtils::push_uniq(\@{ $self->{'binfiles'}{$arch} }, @files);
}
sub remove_binfiles {
  my ($self,$arch,@files) = @_;
  my @finalfiles;
  foreach my $f (@{$self->{'binfiles'}{$arch}}) {
    if (not(&TeXLive::TLUtils::member($f,@files))) {
      push @finalfiles,$f;
    }
  }
  $self->{'binfiles'}{$arch} = [ @finalfiles ];
}
sub runfiles {
  my $self = shift;
  if (@_) { @{ $self->{'runfiles'} } = @_ }
  return @{ $self->{'runfiles'} };
}
sub runsize {
  my $self = shift;
  if (@_) { $self->{'runsize'} = shift }
  return ( defined($self->{'runsize'}) ? $self->{'runsize'} : 0 );
}
sub add_runfiles {
  my ($self,@files) = @_;
  $self->add_files("run",@files);
}
sub remove_runfiles {
  my ($self,@files) = @_;
  $self->remove_files("run",@files);
}
sub add_files {
  my ($self,$type,@files) = @_;
  die("Cannot use add_files for binfiles, we need that arch!") if ($type eq "bin");
  &TeXLive::TLUtils::push_uniq(\@{ $self->{"${type}files"} }, @files);
}
sub remove_files {
  my ($self,$type,@files) = @_;
  die("Cannot use add_files for binfiles, we need that arch!") if ($type eq "bin");
  my @finalfiles;
  foreach my $f (@{$self->{"${type}files"}}) {
    if (not(&TeXLive::TLUtils::member($f,@files))) {
      push @finalfiles,$f;
    }
  }
  $self->{"${type}files"} = [ @finalfiles ];
}
sub depends {
  my $self = shift;
  if (@_) { @{ $self->{'depends'} } = @_ }
  return @{ $self->{'depends'} };
}
sub executes {
  my $self = shift;
  if (@_) { @{ $self->{'executes'} } = @_ }
  return @{ $self->{'executes'} };
}

sub zipdir {
  my @self = shift;
  if (@_) { $_zipdir = $_[0] }
  return $_zipdir;
}

1;



###### Formats
format multilineformat =
longdesc ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
$_tmp
.

### Local Variables:
### perl-indent-level: 2
### tab-width: 2
### indent-tabs-mode: nil
### End:
# vim:set tabstop=2: #