File Coverage

blib/lib/Lingua/DE/Wortschatz.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

#$Id: Wortschatz.pm 1151 2008-10-05 20:57:26Z schroeer $

package Lingua::DE::Wortschatz;

use strict;
use SOAP::Lite;# +trace=>'all';
use HTML::Entities;
use Text::Autoformat;
use Exporter 'import';
use Data::Dumper;
$Data::Dumper::Indent=1;

our @EXPORT_OK = qw(use_service help);
our %EXPORT_TAGS = (all => [@EXPORT_OK]);

our $VERSION = "1.27";

my $BASE_URL = 'http://anonymous:[e-mail]:8100/axis/services/';
my $LIMIT    = 10;
my $MINSIG   = 1;

#description of available services and necessary corpus, in and out parameters
my %services=( # service_name => [ 'corpus', [ 'inparam<=default>', .. ], [ 'outparam', .. ] )
    ServiceOverview => [ 'webservice', ['Name='], ['Name','Id','Status','Description','AuthorizationLevel','InputFields'] ],
    Cooccurrences   => [ 'de', ['Wort',"Mindestsignifikanz=$MINSIG","Limit=$LIMIT"], ['Wort','Kookkurrenz','Signifikanz'] ],
    Baseform        => [ 'de', ['Wort'], ['Grundform','Wortart'] ],
    Sentences       => [ 'de', ['Wort',"Limit=$LIMIT"], ['Satz'] ],
    RightNeighbours => [ 'de', ['Wort',"Limit=$LIMIT"], ['Wort','Nachbar','Signifikanz'] ],
    LeftNeighbours  => [ 'de', ['Wort',"Limit=$LIMIT"], ['Nachbar','Wort','Signifikanz'] ],
    Frequencies     => [ 'de', ['Wort'], ['Anzahl','Frequenzklasse'] ],
    Synonyms        => [ 'de', ['Wort',"Limit=$LIMIT"], ['Synonym'] ],
    Thesaurus       => [ 'de', ['Wort',"Limit=$LIMIT"], ['Synonym'] ],
    Wordforms       => [ 'de', ['Word',"Limit=$LIMIT"], ['Form'] ], #find the trap that wortschatz.u-l guys have hidden here
    Similarity      => [ 'de', ['Wort',"Limit=$LIMIT"], ['Wort','Verwandter','Signifikanz'] ],
    LeftCollocationFinder
                    => [ 'de', ['Wort','Wortart',"Limit=$LIMIT"], ['Kollokation','Wortart','Wort'] ],
    RightCollocationFinder
                    => [ 'de', ['Wort','Wortart',"Limit=$LIMIT"], ['Wort','Kollokation','Wortart'] ],
    Sachgebiet      => [ 'de', ['Wort'], ['Sachgebiet'] ],
    Kreuzwortraetsel
                    => [ 'de', ['Wort','Wortlaenge',"Limit=$LIMIT"], ['Wort'] ],
);

sub use_service {
    #returns a Lingua::DE::Wortschatz::Result object

    #get input parameters and set defaults or return undef if service unknown or insufficent parameters
    my $service=parse_servicename(shift) || return undef;
    my %params;
    for (@{$services{$service}->[1]}) {
        if (/([^=]+)=(.*)/) { $params{$1}=shift || $2}
        else                { $params{$_}=shift || return undef }
    }
    my $corpus=$services{$service}->[0];
    my @resultnames=@{$services{$service}->[2]};

    # perform the soap query
    my $soap = SOAP::Lite->proxy($BASE_URL.$service);
    my $result=$soap->execute(make_params($corpus,\%params));
    #print Dumper($result);
    #print $soap->execute(make_params($corpus,\%params))->{_context}->{_transport}->{_proxy}->{_http_response}->{_content};
    die "SOAP has returned an error (".$result->faultcode."):\n".$result->faultstring if ($result->fault);

    # bring results into shape
    # wortschatz has two different kind of return types; kind of scalar and list
    my @res=$result->valueof('//result/'.((@resultnames > 1) ? '*' : 'dataVectors').'/*');
    my $resobj=Lingua::DE::Wortschatz::Result->new($service,@resultnames);
    $resobj->add(splice @res,0,@resultnames) while (@res);
    return $resobj;
}

sub help {
    my $cmd=shift || 'list';
    $cmd = parse_servicename($cmd) || 'list' unless ($cmd =~ /(list)|(full)/);
    my @so=use_service('ServiceOverview')->hashrefs();
    my $help=($cmd =~ /(list)|(full)/) ? "Available services:\n" : "";
    for my $so (@so) {
        my $sn=$so->{Name};
        if ($services{$sn} && (($sn =~ /^$cmd/) || ($cmd =~ /(list)|(full)/))) {
            $help.=sprintf "* %s %s %s %s\n",$sn,@{$services{$sn}->[1]},"","","";
            unless ($cmd eq 'list') {
                my $t="\n  ".decode_entities($so->{Description})."\n\n";
                $help.=autoformat($t,{all=>1})."\n";
            }
        }
    }
    return $help;
}

sub make_params {
    # create the soap request parameters by hand
    # not the idea of soap, but everything else failed (see manpage)
    my ($corpus,$params)=@_;
    my $ns='http://datatypes.webservice.wortschatz.uni-leipzig.de';
    my $xml="$corpus";
    my $num=1;
    for (keys %$params) {
        $xml.=q ().
              qq($_).
              qq($$params{$_}).
              q ();
        $num++;
    }
    $xml.='';
    SOAP::Data->type(xml=>$xml);
}

sub parse_servicename {
    my ($service)=grep(/^$_[0]/,keys %services);
    return $service;
}

package Lingua::DE::Wortschatz::Result;
use strict;

our $VERSION = $Lingua::DE::Wortschatz::VERSION;

sub new {
    my ($proto,$service,@names) = @_;
    my $class = ref($proto) || $proto;
    return bless { service => $service, names => \@names, data => [] }, $class;
}

sub add {
    my ($self,@values)=@_;
    push(@{$self->{data}},\@values);
}

sub dump {
    my $self=shift;
    print "Service ",$self->service,"\n\n";
    my @lengths;
    for my $row ($self->data,$self->{names}) {
        for (0..$#$row) {
            my $l=length($row->[$_]);
            $lengths[$_]=$l unless ($lengths[$_] && ($lengths[$_] > $l));
        }
    }
    my $form=(join " ",map {'%-'.$_.'s'} @lengths)."\n";
    printf $form,$self->names;
    printf $form, map {"-"x$_} @lengths;
    printf $form,@$_ for ($self->data);
}

sub service { shift->{service} }

sub names { @{shift->{names}} }

sub data { @{shift->{data}} }

sub hashrefs {
    my $self=shift;
    my @res=();
    for (@{$self->{data}}) {
        my %hash;
        @hash{@{$self->{names}}}=@$_;
        push(@res,\%hash);
    }
    return @res;
}

1;

__END__