skripte/apply-pattern.pl

   1 #! /usr/bin/perl -w
   2 #
   3 # apply-pattern.pl
   4 #
   5 # Dieses Perl-Skript wendet die TeX-Trennmusterdatei $1 auf den Datenstrom
   6 # an, wobei $2 als Translationsdatei benutzt wird (das ist diejenige Datei,
   7 # die `patgen' als viertes Argument benötigt).
   8 #
   9 # Folgende Zeichen werden vor der Weiterverarbeitung aus der Eingabe
  10 # herausgefiltert:
  11 #
  12 #   · - = | < >
  13 #
  14 # Ist Option `-1' nicht gegeben, werden Trennungen direkt nach dem ersten
  15 # und vor dem letzten Buchstaben in der Ausgabe entfernt, wie z.B. bei
  16 # deutschen Trennungen erforderlich.
  17 #
  18 # Dieses Skript benützt patgen, nicht TeX!  Die Trennmusterdatei darf daher
  19 # keine TeX-Konstrukte (Makros u.ä.) enthalten.
  20 #
  21 # Aufruf:  perl apply-pattern.pl trennmuster german.tr < eingabe > ausgabe
  22
  23 use strict;
  24 use Encode;
  25 use File::Spec;
  26 use File::Temp;
  27
  28 use Getopt::Std;
  29 getopts('1');
  30
  31 our ($opt_1);
  32
  33 my $prog = $0;
  34 $prog =~ s@.*/@@;
  35
  36 if ($#ARGV != 1) {
  37   die "Aufruf:  $prog [-1] trennmuster german.tr < eingabe > ausgabe\n" .
  38       "\n" .
  39       "  `eingabe', `ausgabe' in UTF-8-Kodierung,\n" .
  40       "  `trennmuster', `german.tr' in ISO-8859-15-Kodierung\n" .
  41       "\n" .
  42       "  Mit Option `-1' bleiben Trennungen nach dem ersten und\n" .
  43       "  vor dem letzten Buchstaben in der Ausgabe.\n";
  44 }
  45
  46 my $trennmuster = File::Spec->rel2abs($ARGV[0]);
  47 my $translation = File::Spec->rel2abs($ARGV[1]);
  48 my $tempdir = File::Temp::tempdir(CLEANUP => 1);
  49 my $tempdatei = "pattern";
  50 my $null = File::Spec->devnull();
  51 my $stdin = "input";
  52
  53 chdir $tempdir
  54 || die "$prog: Kann nicht ins temporäre Verzeichnis `$tempdir' wechseln: $!\n";
  55
  56 my @eingabe;
  57
  58 open TEMP, '>', $tempdatei
  59 || die "$prog: Kann temporäre Datei `$tempdatei' nicht öffnen: $!\n";
  60
  61 binmode(STDIN, ":encoding(utf8)");  # Eingabe (wortliste) in UTF-8
  62 binmode(TEMP, ":encoding(iso-8859-15)"); # patgen erwartet Latin-9
  63
  64 while (<STDIN>) {
  65   s/[·=|<>-]//g;
  66   push(@eingabe, $_);
  67   print TEMP $_;
  68 }
  69 close TEMP;
  70
  71 open TEMP, '>', $stdin
  72 || die "$prog: Kann temporäre Datei `$stdin' nicht öffnen: $!\n";
  73 print TEMP "9 8\n";
  74 print TEMP "y\n";
  75 close TEMP;
  76
  77 # Portables Umleiten von stdin, stdout und stderr ...
  78 open STDOUT_ALT, '>&', \*STDOUT
  79 || die "$prog: Kann STDOUT nicht duplizieren: $!\n";
  80 open STDERR_ALT, '>&', \*STDERR
  81 || die "$prog: Kann STDERR nicht duplizieren: $!\n";
  82 open STDOUT, '>', $null
  83 || die "$prog: Kann STDOUT nicht zur Nullausgabe umleiten: $!\n";
  84 open STDERR, '>', $null
  85 || die "$prog: Kann STDERR nicht zur Nullausgabe umleiten: $!\n";
  86 open STDIN, $stdin
  87 || die "$prog: Kann `$stdin' nicht nach STDIN umleiten: $!\n";
  88
  89 my $status = system("patgen $tempdatei $trennmuster $null $translation");
  90 my $fehler = $?;
  91
  92 open STDOUT, '>&', \*STDOUT_ALT
  93 || die "$prog: Kann STDOUT nicht wieder herstellen: $!\n";
  94 open STDERR, '>&', \*STDERR_ALT
  95 || die "$prog: Kann STDERR nicht wieder herstellen: $!\n";
  96
  97 die "$prog: Aufruf von patgen fehlgeschlagen: $fehler\n" if $status;
  98
  99 my @muster;
 100 my ($pattmp) = <pattmp.*>;
 101 open PATGEN, $pattmp
 102 || die "$prog: Kann von patgen erzeugte Datei `$pattmp' nicht öffnen: $!\n";
 103 while (<PATGEN>) {
 104   s/\./-/g;
 105   s/^(.)-/$1/ if not $opt_1;
 106   s/-(.)$/$1/ if not $opt_1;
 107   push(@muster, $_);
 108 }
 109 close PATGEN;
 110
 111 binmode(STDOUT, ":encoding(utf8)"); # Ausgabe ist wieder UTF-8
 112
 113 while (@eingabe) {
 114   my @vorlage = split(//, shift(@eingabe));
 115   my @ergebnis = split(//, shift(@muster));
 116   my $i = 0;
 117   my $j = 0;
 118
 119   # letztes Zeichen ist immer \n, daher < und nicht <=
 120   while ($i < $#vorlage) {
 121     $j++ if ($ergebnis[$j] eq '-');
 122     $ergebnis[$j++] = $vorlage[$i++];
 123   }
 124   print @ergebnis;
 125 }
 126
 127 END {
 128   chdir($ENV{HOME}) || chdir('/');
 129 }
 130
 131 # eof