TLDB module

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

3 files changed, 113 insertions, 8 deletions

diff --git a/new-infra/TLDB.pm b/new-infra/TLDB.pm
new file mode 100644
index 00000000000..3c23e94989c
--- /dev/null
+++ b/new-infra/TLDB.pm
@@ -0,0 +1,57 @@
+#
+# TLDB.pm
+# module for using tldb files
+# Copyright 2007 Norbert Preining
+#
+# This file is licensed under the GNU General Public Licence version 2
+# or any later version
+
+package TLDB;
+
+use TLP;
+
+sub new { 
+	my $class = shift;
+	my %params = @_;
+	my $self = {};
+	bless $self, $class;
+	return $self;
+}
+
+sub add_tlp {
+	my ($self,$tlp) = @_;
+	$self->{$tlp->name} = $tlp;
+}
+
+sub from_file {
+	my $self = shift;
+	if (@_ != 1) {
+		die("Need a filename for initialization!");
+	}
+	open(TMP,"<$_[0]") || die("Cannot open tldb file: $_[0]");
+	do {
+		my $tlp = TLP->new;
+		my $found = $tlp->from_fh(\*TMP,1);
+		if ($found) {
+			$self->add_tlp($tlp);
+		}
+	} until (!$found);
+}
+
+sub writeout {
+	my $self = shift;
+	my $fd = (@_ ? $_[0] : STDOUT);
+	foreach (sort keys %$self) {
+		$self->{$_}->writeout($fd);
+		print $fd "\n";
+	}
+}
+
+1;
+
+### Local Variables:
+### perl-indent-level: 4
+### tab-width: 4
+### indent-tabs-mode: t
+### End:
+# vim:set tabstop=4: #
diff --git a/new-infra/TLP.pm b/new-infra/TLP.pm
index 5b10dd952b3..b4c19221164 100644
--- a/new-infra/TLP.pm
+++ b/new-infra/TLP.pm
@@ -32,24 +32,40 @@ sub new {
 	return $self;
 }
 
+# sub from_file {
+# 	my $self = shift;
+# 	if (@_ != 1) {
+# 		die("Need a filename for initialization!");
+# 	}
+# 	open(TMP,"<$_[0]") || die("Cannot open tlp file: $_[0]");
+# 	my @lines = <TMP>;
+# 	close(TMP);
+
 sub from_file {
 	my $self = shift;
 	if (@_ != 1) {
 		die("Need a filename for initialization!");
 	}
 	open(TMP,"<$_[0]") || die("Cannot open tlp file: $_[0]");
-	my @lines = <TMP>;
-	close(TMP);
+	$self->from_fh(\*TMP);
+}
+	
+sub from_fh {
+	my ($self,$fh,$multi) = @_;
 	my $started = 0;
-	my $finished = 0;
 	my $lastcmd = "";
 
-	foreach my $line (@lines) {
+	while (my $line = $fh->getline) {
 		$line =~ /^\s*#/ && next;          # skip comment lines
 		if ($line =~ /^\s*$/) {
 			if (!$started) { next; }
-			if ($finished) { next; }
-			die("No empty line allowed within tlp files!");
+			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 tlp files!");
+			}
 		}
 		if ($line =~ /^ /) {
 			if ( ($lastcmd eq "longdesc") ||
@@ -68,7 +84,7 @@ sub from_file {
 			$name = "$1";
 			$lastcmd = "name";
 			$self->name("$name");
-			$started && die("Cannot have two name directives!");
+			$started && die("Cannot have two name directives: $line!");
 			$started = 1;
 		} else {
 			$started || die("First directive needs to be 'name'");
@@ -80,6 +96,10 @@ sub from_file {
 				$self->{'longdesc'} .= "$1 ";
 				$lastcmd = "longdesc";
 				next;
+			} elsif ($line =~ /^revision\s+(.*)$/) {
+				$self->{'revision'} .= "$1 ";
+				$lastcmd = "revision";
+				next;
 			} elsif ($line =~ /^catalogue\s+(.*)$/) {
 				$self->catalogue("$1");
 				$lastcmd = "catalogue";
@@ -109,10 +129,11 @@ sub from_file {
 				$lastcmd = "depend";
 				next;
 			} else {
-				die("Unknown directive ...$line... in $tldb, please fix it!");
+				die("Unknown directive ...$line... , please fix it!");
 			}
 		}
 	}
+	return $started;
 }
 
 sub writeout {
diff --git a/new-infra/test-tldb.pl b/new-infra/test-tldb.pl
new file mode 100644
index 00000000000..373058a6459
--- /dev/null
+++ b/new-infra/test-tldb.pl
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use TLP;
+use TLDB;
+
+my $tldb = new TLDB;
+
+my $tlp = new TLP;
+$tlp->from_file("tlp/baz.tlp");
+$tldb->add_tlp($tlp);
+
+$tlp = new TLP;
+$tlp->from_file("tlp/foo.tlp");
+$tldb->add_tlp($tlp);
+
+open(TMP,">test.tldb");
+$tldb->writeout(\*TMP);
+close(TMP);
+$tldb->writeout;
+
+print "=========================\n";
+
+my $tldbnew = new TLDB;
+$tldb->from_file("test.tldb");
+$tldb->writeout;