first step for perl module code

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

2 files changed, 191 insertions, 0 deletions

diff --git a/new-infra/TLSRC.pm b/new-infra/TLSRC.pm
new file mode 100644
index 00000000000..01a1ae6e209
--- /dev/null
+++ b/new-infra/TLSRC.pm
@@ -0,0 +1,182 @@
+#
+# TLSRC.pm
+# module for using tlsrc files
+# Copyright 2007 Norbert Preining
+#
+# This file is licensed under the GNU General Public Licence version 2
+# or any later version
+
+package TLSRC;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(from_file new);
+@EXPORT_OK = qw(from_file new);
+
+sub new { 
+	my $class = shift;
+	my $self = {};
+	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 $tlsrc: $_[0]");
+	my @lines = <TMP>;
+	close(TMP);
+	my $name = "";
+	my $shortdesc = "";
+	my $longdesc= "";
+	my $catalogue = "";
+	my (@executes, @depends);
+	my (@runpatterns, @docpatterns, @binpatterns, @srcpatterns);
+	my $started = 0;
+	my $finished = 0;
+	my $lastcmd = "";
+
+	foreach my $line (@lines) {
+		$line =~ /^\s*#/ && next;          # skip comment lines
+		if ($line =~ /^\s*$/) {
+			if (!$started) { next; }
+			if ($finished) { next; }
+			die("No empty line allowed in tlsrc files!");
+		}
+		if ($line =~ /^ /) {
+			if ( ($lastcmd eq "longdesc") ||
+			     ($lastcmd eq "runpattern")  ||
+			     ($lastcmd eq "binpattern")  ||
+			     ($lastcmd eq "docpattern")  ||
+			     ($lastcmd eq "srcpattern")  ||
+			     ($lastcmd eq "execute")  ||
+				 ($lastcmd eq "depend") ) {
+				$line =~ s/^ /$lastcmd /;
+			} else {
+				die("Continuation of $lastcmd not allowed, please fix tlsrc!\n");
+			}
+		}
+		if ($line =~ /^name\s*([\w-]+)$/) {
+			$name = "$1";
+			$lastcmd = "name";
+			$started && die("Cannot have two name directives!");
+			$started = 1;
+		} else {
+			$started || die("First directive needs to be 'name'");
+			if ($line =~ /^shortdesc\s*(.*)$/) {
+				$shortdesc .= "$1 ";
+				$lastcmd = "shortdesc";
+				next;
+			} elsif ($line =~ /^longdesc\s*(.*)$/) {
+				$longdesc .= "$1 ";
+				$lastcmd = "longdesc";
+				next;
+			} elsif ($line =~ /^catalogue\s*(.*)$/) {
+				$catalogue .= "$1 ";
+				$lastcmd = "catalogue";
+				next;
+			} elsif ($line =~ /^runpattern\s*(.*)$/) {
+				push @runpatterns, "$1";
+				$lastcmd = "runpattern";
+				next;
+			} elsif ($line =~ /^srcpattern\s*(.*)$/) {
+				push @srcpatterns, "$1";
+				$lastcmd = "srcpattern";
+				next;
+			} elsif ($line =~ /^docpattern\s*(.*)$/) {
+				push @docpatterns, "$1";
+				$lastcmd = "docpattern";
+				next;
+			} elsif ($line =~ /^binpattern\s*(.*)$/) {
+				push @binpatterns, "$1";
+				$lastcmd = "binpattern";
+				next;
+			} elsif ($line =~ /^execute\s*(.*)$/) {
+				push @executes, "$1";
+				$lastcmd = "execute";
+				next;
+			} elsif ($line =~ /^depend\s*(.*)$/) {
+				push @depends, "$1";
+				$lastcmd = "depend";
+				next;
+			} else {
+				die("Unknown directive ...$line... in $tlsrc, please fix it!");
+			}
+		}
+	}
+	$self->{'name'} = "$name";
+	$self->{'catalogue'} = $catalogue ne "" ? "$catalogue" : "$name";
+	if ($shortdesc ne "") {
+		$self->{'shortdesc'} = "$shortdesc";
+	}
+	if ($longdesc ne "") {
+		$self->{'longdesc'} = "$longdesc";
+	}
+	if ($#srcpatterns >= 0) {
+		$self->{'srcpatterns'} = [ @srcpatterns ];
+	}
+	if ($#runpatterns >= 0) {
+		$self->{'runpatterns'} = [ @runpatterns ];
+	}
+	if ($#binpatterns >= 0) {
+		$self->{'binpatterns'} = [ @binpatterns ];
+	}
+	if ($#docpatterns >= 0) {
+		$self->{'docpatterns'} = [ @docpatterns ];
+	}
+	if ($#executes >= 0) {
+		$self->{'executes'} = [ @executes ];
+	}
+	if ($#depends>= 0) {
+		$self->{'depends'} = [ @depends ];
+	}
+}
+
+sub display {
+	my $self = shift;
+	print "name $self->{'name'}\n";
+	print "catalogue $self->{'catalogue'}\n";
+	defined($self->{'shortdesc'}) && print "shortdesc $self->{'shortdesc'}\n";
+	defined($self->{'longdesc'}) && print "longdesc $self->{'longdesc'}\n";
+	if (defined($self->{'depends'})) {
+		foreach (@{$self->{'depends'}}) {
+			print "depend $_\n";
+		}
+	}
+	if (defined($self->{'executes'})) {
+		foreach (@{$self->{'executes'}}) {
+			print "execute $_\n";
+		}
+	}
+	if (defined($self->{'srcpatterns'})) {
+		foreach (@{$self->{'srcpatterns'}}) {
+			print "srcpattern $_\n";
+		}
+	}
+	if (defined($self->{'runatterns'})) {
+		foreach (@{$self->{'runpatterns'}}) {
+			print "runpattern $_\n";
+		}
+	}
+	if (defined($self->{'docpatterns'})) {
+		foreach (@{$self->{'docpatterns'}}) {
+			print "docpattern $_\n";
+		}
+	}
+	if (defined($self->{'binpatterns'})) {
+		foreach (@{$self->{'binpatterns'}}) {
+			print "binpattern $_\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/test.pl b/new-infra/test.pl
new file mode 100644
index 00000000000..c33c7767d0f
--- /dev/null
+++ b/new-infra/test.pl
@@ -0,0 +1,9 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use TLSRC;
+
+my $tlsrc = new TLSRC;
+$tlsrc->from_file("tlsrc/foo.tlsrc");
+$tlsrc->display();