[Steak-developer] Perl-version

[Joerg S. <jo...@al...>]

Hier nun mal mein endg=FCltiges Perlprogramm:
#v+
#!/usr/bin/perl -w #T
#
#  Copyright (c) 2002 Razi Lotfi-Tabrizi <ra...@cs...>
#
#  License:  This script is distributed under the terms of version 2
#            of the GNU GPL. See the LICENSE file included with the packa=
ge.
#
my $VERSION=3D"1.8.0";
 =20
use Getopt::Long;
use strict;
use warnings;

my $xcb=3D"/usr/bin/X11/xcb";
my $xcb_opt=3D"-p 0";
my $use_xbuf=3D0;

my $trans=3D"de-en";
my @dicts=3D (["/usr/share/trans/de-en", "de", "en"],
	    ["/dev/null", "de", "fr"],
	    [$ENV{"HOME"}."/.en-de", "en", "de"]);

my %LANGS=3D (de =3D> "German",
	    en =3D> "English",
	    fr =3D> "French");

my $usage=3D"usage: steak [options] [word]...\n".
  "Options:\n".
  "  --and|--or            concatenate the word with \"and\"(default) or =
\"or\"\n".
  "  --[no]clipboard       take the word from the X cut buffer if none is=
 given\n".
  "                        at the command line (default: true)\n".
  "  -i|--[no]ignore       search case insensitiv\n".
  "  -V|--version          print version\n".
  "  --help                print this help message\n";

# parse config

# parse options
my $andor=3D1;
my $version=3D0;
my $help=3D0;
my $ignore_case=3D0;
unless ( GetOptions('and' =3D> sub { $andor=3D1; },
		    'or' =3D> sub { $andor=3D0; },
		    'clipboard!' =3D> \$use_xbuf,
		    'i|ignore!' =3D> \$ignore_case,
		    'trans=3Ds' =3D> \$trans,
		    'V|version' =3D> \$version,
		    'help' =3D> \$help) ) {
	print($usage);
	exit(1);
}
my @words=3D@ARGV;

if ($version) {
    print("steak: $VERSION\n");
    exit(0);
}
if ($help) {
    print($usage);
    exit(0);
}

if (@words =3D=3D 0 && $use_xbuf && -x $xcb) {
    open(XBUF, "-|", "$xcb $xcb_opt") || die;
    @words =3D <XBUF>;
    close(XBUF);
}

if (@words =3D=3D 1 && $words[0] eq "-") {
    shift(@words);
    my $i=3D1;
    while (1) {
	print "word $i: ";
	my $word =3D <>;
	last if (! defined $word || $word eq "\n");
	push(@words, $word);
	++$i;
    }
}

die "No words for translation given\n" if (@words =3D=3D 0);

my ($lang1, $lang2) =3D ($trans =3D~ /([[:alpha:]]{2})-([[:alpha:]]{2})/)=
;

my @files;
foreach (@dicts) {
    my ($file, $lang_l, $lang_r) =3D @{$_};

    next if (! -r $file);
   =20
    if ($lang1 eq $lang_l && $lang2 eq $lang_r) {
	push @files, [ $file, 0 ];
    } elsif ($lang1 eq $lang_r && $lang2 eq $lang_l) {
	push @files, [ $file, 1 ];
    }
}
undef @dicts;

die "No dictionaries found for this language" if ( $#files =3D=3D -1);

print("              --------------------------------------------------\n=
");
print " " foreach (1..(37-length($LANGS{$lang1})));
print "$LANGS{$lang1}  ->  $LANGS{$lang2}\n";

@words =3D map(quotemeta(), @words);
foreach my $f (@files) {
    my ($file, $side) =3D @$f;

    my @regexp;
    if ($andor) {
	if ($side=3D=3D0) {      # left side
	    $_ .=3D ".*::" foreach(@words);
	} else {             # right side
	    $_ =3D "::.*$_" foreach(@words);
	}
	@regexp =3D @words;
    } else {
	my $help;
	if (@words =3D=3D 1) {
	    $help =3D $words[0];
	} else {
	    $help =3D '('.join('|', @words).')';
	}
=09
	if ($side=3D=3D0) {      # left side
	    $help .=3D ".*::";
	} else {             # right side
	    $help =3D "::.*$help";
	}
	push(@regexp, $help);
    }

    open(DICT, "<", $file) || die "Cannot open dictionary file \"$file\":=
 $!";

    my $check;
    foreach (@regexp) {
	$check .=3D 'next if ($_ !~ /'.$_.'/'.($ignore_case?'i':'').');';
    }

    eval('while(<DICT>) {'.
	      'next if (/^#/);'.
	      $check.=20
	      'chomp($_);'.
	      ($side=3D=3D0?
	          's/^ *(.*) *:: *(.*) *$/$1 :=3D=3D $2/;'
	       :
	          's/^ *(.*) *:: *(.*) *$/$2 :=3D=3D $1/;').
	      'print $_,"\n";'.
	 '}');

    close(DICT) || die "Cannot close file: $!";
}
#v-