File Coverage

blib/lib/Lingua/EN/BioLemmatizer.pm

Criterion	Covered	Total	%
statement	110	177	62.1
branch	62	120	51.6
condition	1	11	9.0
subroutine	24	27	88.8
pod	13	13	100.0
total	210	348	60.3

package Lingua::EN::BioLemmatizer;

# See the include pod documentation below for description
# and licensing information.

our $VERSION = 1.002;

use 5.010;
use utf8;
use strict;
use warnings;
use warnings FATAL => "utf8";

use Carp;

use Scalar::Util qw(blessed reftype openhandle);
use IO::Handle;
use IPC::Open2 qw(open2);

########################################################################
########################################################################
########################################################################
#
# procedural interface
#
########################################################################
########################################################################
########################################################################

use base "Exporter";
our @EXPORT_OK = qw(biolemma parse_response);

sub biolemma($;$) {
    croak "no arguments" 	if @_ == 0;
    croak "too many arguments" 	if @_  > 2;
    croak "string args only"	if grep { ref() } @_;
    state $server = __PACKAGE__ -> new();
    return $server->get_biolemma(@_);
}

#
# Input examples:
#   "crisis NNS PennPOS"
#   "xyzzy NONE NONE"
#   "broken j-vvn NUPOS||break VBN PennPOS||break vvn NUPOS"
#   "name vvz NUPOS||name VBZ PennPOS||name NNS PennPOS||name n2 NUPOS"
#   "my po11 NUPOS||i png11 NUPOS||mine n1 NUPOS"
#   "i pno11 NUPOS"
#   "name NN PennPOS||name VBP PennPOS||name vvi NUPOS||name n1 NUPOS||name vvb NUPOS"
#   "crisis NN PennPOS||crisis n1 NUPOS"
#   "those d NUPOS"

sub parse_response($) {
    croak "no arguments" 	if @_ == 0;
    croak "too many arguments" 	if @_  > 1;
    my($string) = @_;
    my @retlist = map { [split] } split /\Q||/, $string;
    return wantarray() ? @retlist : \@retlist;
}

########################################################################
########################################################################
########################################################################
#
# object-oriented interface
#
########################################################################
########################################################################
########################################################################

# constructor for Lingua::EN::BioLemmatizer class
#
# Don't have to worry about leaking the pair of file descriptors we
# allocate because Perl guarantees deterministic resource management,
# so the IO::Handle destructor will correctly close and deallocate
# them when it fires eventually fires.
sub new {
    croak "expected args" if @_ == 0;

    my $invocant = shift();
    if (ref($invocant)) {
	if (blessed($invocant)) {
	    croak "constructor invoked as object method";
	} else {
	    croak "constructor called as function with unblessed ref argument";
	}
    }

    croak "unexpected args" if @_;

    my $self = {
	CHILD_PID 	=> undef,
	INTO_BIOLEMM 	=> undef,
	FROM_BIOLEMM 	=> undef,
	JAVA_PATH	=>   __PACKAGE__ -> java_path,
	JAVA_ARGS	=> [ __PACKAGE__ -> java_args ],
	JAR_PATH	=>   __PACKAGE__ -> jar_path,
	JAR_ARGS	=> [ __PACKAGE__ -> jar_args ],
	LEMMA_CACHE	=> { },
    };

    bless($self, $invocant);

    # XXX: not sure what this is supposed to mean
    if ($ENV{JAVA_HOME}) {
	carp "warning: JAVA_HOME environment variable ignored";
    }

    my @args = $self->command_args();

    my $kidpid = open2(my $pipe_from, my $pipe_into, @args)
		    // croak "can't start double-ended pipe: $!";

    for my $fh ($pipe_from, $pipe_into) {
	binmode($fh, "utf8") || croak "can't binmode($fh, 'utf8'): $!";
    }

    $self->{CHILD_PID} = $kidpid;
    $self->{INTO_BIOLEMM} = $pipe_into;
    $self->{FROM_BIOLEMM} = $pipe_from;

    $self->_skip_interactive_header();

    return $self;
}

sub DESTROY {
    my $self = shift();
    return unless ref $self;
    return unless $self;
    my $pid = $self->child_pid;
    return unless $pid;
    close $self->into_biolemmer();
    close $self->from_biolemmer();
    kill TERM => $pid;
    waitpid($pid, 0);
}

# getters/setters for Lingua::EN::BioLemmatizer objects
#

# only object getter allowed
sub child_pid {
    my $self = shift();
    croak "object method called as class method" unless ref $self;
    croak "readonly method called with arguments" if @_;
    return $self->{CHILD_PID};
}

# only object getter allowed
sub into_biolemmer {
    my $self = shift();
    croak "object method called as class method" unless ref $self;
    croak "readonly method called with arguments" if @_;
    return $self->{INTO_BIOLEMM};
}

# only object getter allowed
sub from_biolemmer {
    my $self = shift();
    croak "object method called as class method" unless ref $self;
    croak "readonly method called with arguments" if @_;
    return $self->{FROM_BIOLEMM};
}

# only object getter allowed
sub lemma_cache {
    my $self = shift();
    croak "object method called as class method" unless ref $self;
    croak "readonly method called with arguments" if @_;
    return $self->{LEMMA_CACHE};
}

# dual method: object getter or class getter/setter
sub java_path {
    state $_Java_Path = "java";
    my $self = shift();
    if (ref $self) {
	croak "readonly method called with arguments" if @_;
	return $self->{JAVA_PATH};
    }
    croak "expected no more than 1 argument" if @_ > 1;
    $_Java_Path = $_[0] if @_;
    return $_Java_Path;
}

# dual method: object getter or class getter/setter
sub jar_path {
    state $_Jar_Path = $ENV{BIOLEMMATIZER} || "biolemmatizer-core-1.0-jar-with-dependencies.jar";
    my $self = shift();
    if (ref $self) {
	croak "readonly method called with arguments" if @_;
	return $self->{JAR_PATH};
    }
    $_Jar_Path = $_[0] if @_;
    ## unless (-e $_Jar_Path) { carp "cannot access $_Jar_Path: $!"; }
    return $_Jar_Path;
}

# dual method: object getter or class getter/setter
sub java_args {
    state $_Java_Args = [ "-Xmx1G", "-Dfile.encoding=utf8" ],
    my $self = shift();
    if (ref $self) {
	croak "readonly method called with arguments" if @_;
	return wantarray() ? @{ $self->{JAVA_ARGS} } : $self->{JAVA_ARGS};
    }

    if (@_ == 1) {
	my $arg = shift();
	if (ref($arg)) {
	    croak "unexpected non-arrayref arg" unless ref($arg) eq "ARRAY";
	    $_Java_Args = $arg;
	}
	else {
	    $_Java_Args = [ $arg ];
	}
    }
    elsif (@_ > 1) {
	croak "unexpected ref arg" if grep { ref() } @_;
	$_Java_Args = [ @_ ];
    }
    else {
	# FALLTHROUGH
    }

    return wantarray() ? @{ $_Java_Args } : $_Java_Args;
}

# dual method: object getter or class getter/setter
sub jar_args {
    state $_Jar_Args = [ "-t" ],
    my $self = shift();
    if (ref $self) {
	croak "readonly method called with arguments" if @_;
	return wantarray() ? @{ $self->{JAR_ARGS} } : $self->{JAR_ARGS};
    }

    if (@_ == 1) {
	my $arg = shift();
	if (ref($arg)) {
	    croak "unexpected non-arrayref arg" unless ref($arg) eq "ARRAY";
	    $_Jar_Args = $arg;
	}
	else {
	    $_Jar_Args = [ $arg ];
	}
    }
    elsif (@_ > 1) {
	croak "unexpected ref arg" if grep { ref() } @_;
	$_Jar_Args = [ @_ ];
    }
    else {
	# FALLTHROUGH
    }

    return wantarray() ? @{ $_Jar_Args } : $_Jar_Args;
}

########################################################################

#################
# other methods
#################

# dual class/object method
sub command_args {
    my $invocant = shift();
    croak "unexpected args" if @_;

    my @args = (
	$invocant->java_path,
	$invocant->java_args,
	"-jar",
	$invocant->jar_path,
	$invocant->jar_args,
    );

    return wantarray() ? (@args) : "@args";
}

# object method only, not class method
sub get_biolemma {
    my $self = shift();
    croak "object method called as class method" unless ref $self;

    my($orig, $pos);

    given(scalar(@_)) {
	when (2) { ($orig, $pos) = @_ }
	when (1) { ($orig)       = @_ }
	when (0) { croak "expected 1 or 2 args" }
	default  { croak "too many args" }
    }

    my $cache_ref = $self->lemma_cache;

    my $string  = $orig;
       $string .= " $pos" 	if $pos;

    # This funny "||=" move (sometimes called the "orkish maneuver"
    # == "OR-cache maneuver") loads cache only if that slot previously
    # false, then returns whatever is there.
    #
    return $cache_ref->{$string} ||= $self->_handle_request($string);
}

# private object method only, not class method
sub _handle_request {
    croak "don't call private methods" unless caller eq __PACKAGE__;
    my $self = shift();
    croak "object method called as class method" unless ref $self;
    croak "expected just one arg" unless @_ == 1;

    my($request) = @_;

    $request =~ s/\R+\z//;   # remove any trailing linebreaks
			     # lest a blank line kill server

    {
	local $SIG{PIPE} = sub { croak "biolemmatizer pipe broke" };
	print { $self->into_biolemmer } $request, "\n";
    }

    my $response = $self->from_biolemmer->getline()
		 // croak "no return string from biolemmatizer";

    $response =~ s/\R+\z//;
    return $response;
}

# private object method to skip the noisy preamble strings
# that it spits out when the process is first started up.
# The exact header is the five lines following, without the ##:

## =========================================================
## =========================================================
## =========================================================
## Running BioLemmatizer....
## Running BioLemmatizer in interactive mode. Please type a word to be lemmatized with an optional part-of-speech, e.g. "run" or "run NN"

sub _skip_interactive_header {
    croak "don't call private methods" unless caller eq __PACKAGE__;
    my $self = shift();
    croak "object method called as class method" unless ref $self;
    croak "expected no args" unless @_ == 0;

    my $fh = $self->from_biolemmer();

    # NB: these are blockings reads.

    # three lines of equal signs
    for (1..3) {
	croak "unexpected preamble: no ===" unless <$fh> =~ /^===/;
    }
    # then two lines of starting with this
    for (1..2) {
	croak "unexpected preamble: no greeting" unless <$fh> =~ /^Running BioLemmatizer/;
    }
}


# last "1;" is so that "use" and "require"
# consider the module properly intialized
#
1;    # don't delete this!

__END__