skripte/extract-tex.pl

   1 #! /usr/bin/perl -w
   2 #
   3 # extract-tex.pl
   4 #
   5 # Dieses Perl-Skript extrahiert einfache Wortlisten aus der
   6 # »wortliste«-Datenbank, die beispielsweise als Eingabedateien für »patgen«
   7 # verwendet werden können.
   8 #
   9 # Aufruf:  perl extract-tex.pl [Optionen...] < wortliste > input.patgen
  10 #
  11 # Die »wortliste«-Datei muss in UTF-8 kodiert sein.
  12 #
  13 # Option »-t« wählt die traditionelle deutsche Rechtschreibung aus, Option
  14 # »-s« die traditionelle (deutsch)schweizerische Rechtschreibung.  Wenn
  15 # weder »-s« noch »-t« gesetzt ist, wird die reformierte deutsche
  16 # Rechtschreibung ausgewählt.
  17 #
  18 # Ist Option »-x« gesetzt, werden Optionen »-g« und »-u« ignoriert und die
  19 # die sprachspezifischen Felder unbearbeitet ausgegeben.
  20 #
  21 # Option »-g« bewirkt die Ausgabe von Wörtern mit gewichteten Trennstellen;
  22 # Wörter mit »·« werden ignoriert.
  23 #
  24 # Option »-u« verhindert die Ausgabe von Wörtern mit Markern für
  25 # unerwünschte Trennungen (z.B. »An-al.pha-bet«).
  26 #
  27 # Option »-v« verhindert die Ausgabe von Versalformen, wo »ß« durch »ss«
  28 # ersetzt ist.
  29 #
  30 # Option »-l« konvertiert die Ausgabe nach latin-1 (wie von »patgen«
  31 # benötigt).
  32
  33 use strict;
  34 use utf8;         # String-Literals direkt als UTF-8
  35 use Getopt::Std;
  36 getopts('glstuvx');
  37
  38 our ($opt_g, $opt_l, $opt_s, $opt_t, $opt_u, $opt_v, $opt_x);
  39
  40 my $prog = $0;
  41 $prog =~ s@.*/@@;
  42
  43 # Kodierung:
  44 binmode(STDIN, ":encoding(utf8)");
  45
  46 if ($opt_l) {
  47   binmode(STDOUT, ":encoding(latin1)");
  48 }
  49 else {
  50   binmode(STDOUT, ":encoding(utf8)");
  51 }
  52
  53 sub entferne_marker {
  54   my $arg = shift;
  55   $arg =~ s/[-=|·]//g;
  56   return $arg;
  57 }
  58
  59 while (<>) {
  60   chop;
  61   next if /^#/;
  62
  63   # entferne Kommentare
  64   s/#.*$//;
  65
  66   # entferne Leerzeichen aller Art
  67   s/\s+//g;
  68
  69   my @feld = split(';');
  70   next if $#feld < 1;
  71
  72   # reformiert:           Felder 2, 4, 5, 7
  73   # traditionell:         Felder 2, 3, 5, 6
  74   # traditionell Schweiz: Felder 2, 3, 5, 6, 8
  75   my $zeile = $feld[1];
  76   $zeile = $feld[2] if defined $feld[2]
  77                        && $feld[2] ne "-3-" && ($opt_t || $opt_s);
  78   $zeile = $feld[3] if defined $feld[3]
  79                        && $feld[3] ne "-4-" && !($opt_t || $opt_s);
  80   $zeile = $feld[4] if defined $feld[4]
  81                        && $feld[4] ne "-5-" && !$opt_v;
  82   $zeile = $feld[5] if defined $feld[5]
  83                        && $feld[5] ne "-6-" && ($opt_t || $opt_s) && !$opt_v;
  84   $zeile = $feld[6] if defined $feld[6]
  85                        && $feld[6] ne "-7-" && !($opt_t || $opt_s) && !$opt_v;
  86   $zeile = $feld[7] if defined $feld[7]
  87                        && $feld[7] ne "-8-" && $opt_s && !$opt_v;
  88
  89   next if $zeile eq "-2-";
  90
  91   if (!$opt_x) {
  92     # entferne spezielle Trennungen
  93     $zeile =~ s|\{ (.*?) / .*? \}|$1|gx;
  94     # entferne Doppeldeutigkeiten
  95     $zeile =~ s|\[ (.*?) / .*? \]|entferne_marker($1)|egx;
  96
  97     # Ausgabe von Wörtern mit unerwünschten Trennungen?
  98     next if $zeile =~ /[._]/ and $opt_u;
  99     # entferne Markierungen für unerwünschte Trennungen
 100     $zeile =~ s/[·|=-]*[._]+[·|=-]*//g;
 101
 102     # Ausgabe von Wörtern mit ungewichteten Trennstellen?
 103     next if $zeile =~ /·/ and $opt_g;
 104     # reduziere Trennstellenmarker zu »-«, falls gewollt
 105     $zeile =~ s/[·|=-]+/-/g if not $opt_g;
 106   }
 107
 108   print "$zeile\n";
 109 }
 110
 111 # eof