Implement most of pinning action

use the new TLConfFile multiple value approach to manage the pinning file.
Do all the pin-data handling tlpdb internal

git-svn-id: svn://tug.org/texlive/trunk@29228 c570f23f-e606-0410-a88d-b1316a301751

2 files changed, 114 insertions, 57 deletions

diff --git a/Master/texmf/scripts/texlive/tlmgr.pl b/Master/texmf/scripts/texlive/tlmgr.pl
index 769b9e4aacc..eaa3134334c 100755
--- a/Master/texmf/scripts/texlive/tlmgr.pl
+++ b/Master/texmf/scripts/texlive/tlmgr.pl
@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 # $Id$
 #
-# Copyright 2008, 2009, 2010, 2011, 2012 Norbert Preining
+# Copyright 2008, 2009, 2010, 2011, 2012, 2013 Norbert Preining
 # This file is licensed under the GNU General Public License version 2
 # or any later version.
 
@@ -24,6 +24,7 @@ our $loadmediasrcerror;
 our $packagelogfile;
 our $packagelogged;
 our $tlmgr_config_file;
+our $pinfile;
 
 BEGIN {
   $^W = 1;
@@ -161,6 +162,7 @@ sub main {
                          "dry-run|n" => 1 },
     "paper"         => { "list" => 1 },
     "path"          => { "w32mode" => "=s" },
+    "pinning"       => { "all" => 1 },
     "platform"      => { "dry-run|n" => 1 },
     "postaction"    => { "w32mode" => "=s",
                          "all" => 1,
@@ -3510,7 +3512,76 @@ sub show_list_of_packages {
 # tlmgr pinning remove <repo> <pkgglob> [<pkgglob>, ...]
 # tlmgr pinning remove <repo> --all
 sub action_pinning {
-  tlwarn("Not implemented by now, sorry!\n");
+  my $what = shift @ARGV;
+  $what || ($what = 'show');
+  init_local_db();
+  init_tlmedia_or_die();
+  if (!$remotetlpdb->is_virtual) {
+    tlwarn("tlmgr: not a virtual database, no pinning actions supported!\n");
+    return;
+  }
+  my $pinref = $remotetlpdb->virtual_pindata();
+  my $pf = $remotetlpdb->virtual_pinning();
+  my @pins = @$pinref;
+  if ($what =~ m/^show$/i) {
+    print "Defined pinning data:\n";
+    for my $p (@pins) {
+      print "  ", $p->{'repo'}, ":", $p->{'glob'}, "\n";
+    }
+  } elsif ($what =~ m/^check$/i) {
+    tlwarn("Not implemented by now, sorry!\n");
+    return 0;
+  } elsif ($what =~ m/^add$/i) {
+    # we need at least two more arguments
+    if ($#ARGV < 1) {
+      tlwarn("missing arguments to pinning add\n");
+      return;
+    }
+    my $repo = shift @ARGV;
+    my @ov = $pf->value($repo);
+    push @ov, @ARGV;
+    $pf->value($repo, @ov);
+    $remotetlpdb->virtual_update_pins();
+    $pf->save;
+    info("Added/Updated pinning data for $repo\n");
+    return 1;
+  } elsif ($what =~ m/^remove$/i) {
+    my $repo = shift @ARGV;
+    if (!defined($repo)) {
+      tlwarn("missing arguments to pinning add\n");
+      return;
+    }
+    my $pf = $remotetlpdb->virtual_pinning();
+    if ($opts{'all'}) {
+      if ($#ARGV >= 0) {
+        tlwarn("no additional argument allowed when --all is given\n");
+        return;
+      }
+      $pf->delete_key($repo);
+      $remotetlpdb->virtual_update_pins();
+      $pf->save;
+      return;
+    }
+    # complicated case, we want to remove only one setting
+    my @ov = $pf->value($repo);
+    my @nv;
+    for my $pf (@ov) {
+      push @nv, $pf if (!member($pf, @ARGV));
+    }
+    $pf->value($repo, @nv);
+    $remotetlpdb->virtual_update_pins();
+    $pf->save;
+    info("Removed pinning data for $repo\n");
+    return 1;
+  } else {
+    tlwarn("Unknown argument to pinning action: $what\n");
+    return 0;
+  }
+  # $pin{'repo'} = $repo;
+  # $pin{'glob'} = $glob;
+  # $pin{'re'} = $re;
+  # $pin{'line'} = $line; # for debug/warning purpose
+  return 0;
 }
 
 #  REPOSITORY
@@ -5185,24 +5256,19 @@ sub init_tlmedia
 
   # now check/setup pinning
   # TODO for now no default pinning file!
-  if ($opts{"pin-file"}) {
-    my @pins = read_pinning_file($opts{"pin-file"});
-    if (@pins) {
-      $remotetlpdb->virtual_pinning(@pins);
-    }
-  } else {
+  if (!$opts{"pin-file"}) {
     # check for pinning file in TEXMFLOCAL/tlpkg/pinning.txt
     chomp (my $TEXMFLOCAL = `kpsewhich -var-value=TEXMFLOCAL`);
     debug("trying to load pinning file $TEXMFLOCAL/tlpkg/pinning.txt\n");
     if (-r "$TEXMFLOCAL/tlpkg/pinning.txt") {
-      my @pins = read_pinning_file("$TEXMFLOCAL/tlpkg/pinning.txt");
-      if (@pins) {
-        info("tlmgr: using pinning file $TEXMFLOCAL/tlpkg/pinning.txt\n");
-        $remotetlpdb->virtual_pinning(@pins);
-      }
+      $opts{"pin-file"} = "$TEXMFLOCAL/tlpkg/pinning.txt";
     }
   }
-
+  if ($opts{"pin-file"} && -r $opts{"pin-file"}) {
+    # $pinfile is global var
+    $pinfile = TeXLive::TLConfFile->new($opts{"pin-file"}, "#", ":", 'multiple');
+    $remotetlpdb->virtual_pinning($pinfile);
+  }
   # this "location-url" line should not be changed since GUI programs
   # depend on it:
   print "location-url\t$locstr\n" if $::machinereadable;
@@ -5419,26 +5485,6 @@ FROZEN
   return($remotetlpdb);
 }
 
-sub read_pinning_file {
-  my $pf = shift;
-  my @pins;
-  my $pfh;
-  if (!open($pfh, "<$pf")) {
-    tlwarn("Pinning file $pf cannot be read: $!\n");
-    return;
-  }
-  debug("Reading pinning file $pf\n");
-  while (my $l = TeXLive::TLUtils::get_full_line($pfh)) {
-    chomp($l);
-    # comments and empty lines are allowed
-    next if ($l =~ m/^\s*#/);
-    next if ($l =~ m/^\s*$/);
-    my ($a, $b) = split(/:/, $l);
-    push @pins, $remotetlpdb->make_pin_data_from_line($l);
-  }
-  close($pfh);
-  return @pins;
-}
 
 
 # finish handles the -pause option (wait for input from stdin),
diff --git a/Master/tlpkg/TeXLive/TLPDB.pm b/Master/tlpkg/TeXLive/TLPDB.pm
index 912aacfc8a4..dd136da6df2 100644
--- a/Master/tlpkg/TeXLive/TLPDB.pm
+++ b/Master/tlpkg/TeXLive/TLPDB.pm
@@ -1,6 +1,6 @@
 # $Id$
 # TeXLive::TLPDB.pm - module for using tlpdb files
-# Copyright 2007-2012 Norbert Preining
+# Copyright 2007-2013 Norbert Preining
 # This file is licensed under the GNU General Public License version 2
 # or any later version.
 
@@ -86,7 +86,7 @@ C<TeXLive::TLPDB> -- A database of TeX Live Packages
   $tlpdb->virtual_get_package($pkg, $tag);
   $tlpdb->candidates($pkg);
   $tlpdb->virtual_candidate($pkg);
-  $tlpdb->virtual_pinning( [@tlpkpins ] );
+  $tlpdb->virtual_pinning( [ $pin_file_TLConfFile ] );
 
 =head1 DESCRIPTION
 
@@ -2383,38 +2383,49 @@ sub virtual_candidate {
   return(undef,undef,undef,undef);
 }
 
-=item C<< $tlpdb->virtual_pinning ( [@pinning_data] ) >>
+=item C<< $tlpdb->virtual_pinning ( [ $pinfile_TLConfFile] ) >>
 
-Without any argument returns the pinning data, or undef. Be reminded that an
-empty pinning data will behave differently to no pinning data.
-
-With an argument it must be a list of pins, where each pin
-must be one hash ref with the following keys:
-C<repo> the tag of the repository,
-C<glob> the glob for matching a package
-C<re> the regexp which corresponds to the glob
-C<line> the line where the glob was found (for warning purpose).
+Sets or returns the C<TLConfFile> object for the pinning data.
 
 =cut
 
-sub virtual_pinning {
+sub virtual_pindata {
+  my $self = shift;
+  return ($self->{'pindata'});
+}
+
+sub virtual_update_pins {
   my $self = shift;
-  my (@pins) = @_;
   if (!$self->is_virtual) {
     tlwarn("Not-virtual databases cannot have pinning data.\n");
     return 0;
   }
-  if (!@pins) {
-    if (!defined($self->{'pindata'})) {
-      my @foo = ();
-      $self->{'pindata'} = \@foo;
+  my $pincf = $self->{'pinfile'};
+  my @pins;
+  for my $k ($pincf->keys) {
+    for my $v ($pincf->value($k)) {
+      # we recompose the values into lines again, as we *might* have
+      # options later, i.e., lines of the format
+      #   repo:pkg:opt
+      push @pins, $self->make_pin_data_from_line("$k:$v");
     }
-    return (@{$self->{'pindata'}});
-  } else {
-    $self->{'pindata'} = \@pins;
-    $self->check_evaluate_pinning();
-    return ($self->{'pindata'});
   }
+  $self->{'pindata'} = \@pins;
+  $self->check_evaluate_pinning();
+  return ($self->{'pindata'});
+}
+sub virtual_pinning {
+  my ($self, $pincf) = @_;
+  if (!$self->is_virtual) {
+    tlwarn("Not-virtual databases cannot have pinning data.\n");
+    return 0;
+  }
+  if (!defined($pincf)) {
+    return ($self->{'pinfile'});
+  }
+  $self->{'pinfile'} = $pincf;
+  $self->virtual_update_pins();
+  return ($self->{'pinfile'});
 }
 
 #