view release on metacpan or  search on metacpan

lib/CWB/CL.pm  view on Meta::CPAN

# set CL memory limit (used only by makeall so far, so no point in setting it here)
sub set_memory_limit ( $ ) {
  my $mb = shift;
  croak "Usage:  CWB::CL::set_memory_limit(\$megabytes);"
    unless $mb =~ /^[0-9]+$/;
  croak "CWB::CL: invalid memory limit ${mb} MB (must be >= 42 MB)"
    unless $mb >= 42;
  CWB::CL::cl_set_memory_limit($mb);
}

# convert '|'-delimited string into proper (sorted) feature set value
# (if 's' or 'split' is given, splits string on whitespace; returns undef if there is a syntax error)
*make_set = \&cl_make_set;  # now implemented in pure XS for better efficiency
 
# compute intersection of two feature sets (CQP's 'unify()' function)
# (returns undef if there is a syntax error)
*set_intersection = \&cl_set_intersection;

# compute cardinality of feature set (= "size", i.e. number of elements)
# (returns undef if there is a syntax error)
*set_size = \&cl_set_size;

# convert feature set value into hashref
sub set2hash ( $ ) {
  my $set = shift;
  my $is_ok = defined set_size($set); # easy & fast way of validating feature set format
  if ($is_ok) {
    my @items = split /\|/, $set; # returns empty field before leading |
    shift @items;
    return { map {$_ => 1} @items };
  }
  else {
    return undef;
  }
}


#
#  ------------  CWB::CL::PosAttrib objects  ------------
#

package CWB::CL::PosAttrib;
use Carp;

sub new {
  my $class = shift;
  my $corpus = shift;           # corpus object  (provided by CWB::CL::Corpus->attribute)
  my $name = shift;             # attribute name (provided by CWB::CL::Corpus->attribute)
  my $self = {};

  my $corpusPtr = $corpus->{'ptr'};
  my $ptr = CWB::CL::cl_new_attribute($corpusPtr, $name, $CWB::CL::AttType{'ATT_POS'});
  unless (defined $ptr) {
    my $corpusName = $corpus->{'name'};
    local($Carp::CarpLevel) = 1; # call has been delegated from attribute() method of CWB::CL::Corpus object
    croak("Can't access p-attribute $corpusName.$name (aborted)")
      if CWB::CL::strict(); # CL library doesn't set error code in cl_new_attribute() function
    return undef;
  }
  return bless($ptr, $class);   # objects are just opaque containers for (Attribute *) pointers
}

sub DESTROY {
  my $self = shift;

  # disabled because of buggy nature of CL interface!
  #  CWB::CL::cl_delete_attribute($self);
}

sub max_cpos ( $ ) {
  my $self = shift;

  my $size = CWB::CL::cl_max_cpos($self);
  if ($size < 0) {
    croak CWB::CL::error_message()." (aborted)"
      if CWB::CL::strict();
    return undef;
  }
  return $size;
}

sub max_id ( $ ) {
  my $self = shift;

  my $size = CWB::CL::cl_max_id($self);
  if ($size < 0) {
    croak CWB::CL::error_message()." (aborted)"
      if CWB::CL::strict();
    return undef;
  }
  return $size;
}

*id2str = \&CWB::CL::cl_id2str;

*str2id = \&CWB::CL::cl_str2id;

*id2strlen = \&CWB::CL::cl_id2strlen;

*id2freq = \&CWB::CL::cl_id2freq;

*cpos2id = \&CWB::CL::cl_cpos2id;

*cpos2str = \&CWB::CL::cl_cpos2str;

sub regex2id ( $$;$ ) {
  my $self = shift;
  my $regex = shift;
  my $flags = (@_) ? shift : '';

  croak "Usage:  \$att->regex2id(\$regex [, 'c' | 'd' | 'cd' ]);"
    unless defined $regex and $flags =~ /^(c?d?|dc)$/;

  return CWB::CL::cl_regex2id($self, $regex, $CWB::CL::RegexFlags{$flags});
}

*idlist2freq = \&CWB::CL::cl_idlist2freq;

*idlist2cpos = \&CWB::CL::cl_idlist2cpos;

*id2cpos = \&CWB::CL::cl_idlist2cpos;  # simpler alias (may becomd standard name in future CL releases)


#
#  ------------  CWB::CL::StrucAttrib objects  ------------
#

package CWB::CL::StrucAttrib;
use Carp;

sub new {
  my $class = shift;
  my $corpus = shift;           # corpus object  (provided by CWB::CL::Corpus->attribute)
  my $name = shift;             # attribute name (provided by CWB::CL::Corpus->attribute)

  my $corpusPtr = $corpus->{'ptr'};
  my $ptr = CWB::CL::cl_new_attribute($corpusPtr, $name, $CWB::CL::AttType{'ATT_STRUC'});
  unless (defined $ptr) {
    my $corpusName = $corpus->{'name'};
    local($Carp::CarpLevel) = 1; # call has been delegated from attribute() method of CWB::CL::Corpus object
    croak("Can't access s-attribute $corpusName.$name (aborted)")
      if CWB::CL::strict(); # CL library doesn't set error code in cl_new_attribute() function
    return undef;
  }
  return bless($ptr, $class);
}

sub DESTROY {
  my $self = shift;

  # disabled because of buggy nature of CL interface!
  #  CWB::CL::cl_delete_attribute($self);
}


sub max_struc ( $ ) {
  my $self = shift;

  my $size = CWB::CL::cl_max_struc($self);
  if ($size < 0) {
    croak CWB::CL::error_message()." (aborted)"
      if CWB::CL::strict();
    return undef;
  }
  return $size;
}

sub struc_values ( $ ) {
  my $self = shift;

  my $yesno = CWB::CL::cl_struc_values($self);
  if ($yesno < 0) {
    # so far, CL library generates no errors in this function (just FALSE)
    croak CWB::CL::error_message()." (aborted)"
      if CWB::CL::strict();
    return undef;
  }
  return $yesno;
}

*cpos2struc = \&CWB::CL::cl_cpos2struc;

*cpos2struc2str = \&CWB::CL::cl_cpos2struc2str;
*cpos2str = \&cpos2struc2str; # alias in anticipation of the new object-oriented CL interface specification,

*struc2str = \&CWB::CL::cl_struc2str;

*struc2cpos = \&CWB::CL::cl_struc2cpos;

*cpos2struc2cpos = \&CWB::CL::cl_cpos2struc2cpos;

*cpos2boundary = \&CWB::CL::cl_cpos2boundary;

sub cpos2is_boundary ( $$;@ ){
  my $self = shift;
  my $test = lc(shift);
  my $test_flags = $CWB::CL::Boundary{$test};
  
  croak "Usage:  \$att->cpos2is_boundary({'i'|'o'|'l'|'r'|'lr'}, \$cpos, ...);"
    unless defined $test_flags;
  return CWB::CL::cl_cpos2is_boundary($self, $test_flags, @_);
}

#
#  ------------  CWB::CL::AlignAttrib objects  ------------
#

package CWB::CL::AlignAttrib;
use Carp;

sub new {
  my $class = shift;
  my $corpus = shift;           # corpus object  (provided by CWB::CL::Corpus->attribute)
  my $name = shift;             # attribute name (provided by CWB::CL::Corpus->attribute)
  my $self = {};

  my $corpusPtr = $corpus->{'ptr'};
  my $ptr = CWB::CL::cl_new_attribute($corpusPtr, $name, $CWB::CL::AttType{'ATT_ALIGN'});
  unless (defined $ptr) {
    my $corpusName = $corpus->{'name'};
    local($Carp::CarpLevel) = 1; # call has been delegated from attribute() method of CWB::CL::Corpus object
    croak("Can't access a-attribute $corpusName.$name (aborted)")
      if CWB::CL::strict(); # CL library doesn't set error code in cl_new_attribute() function
    return undef;
  }
  return bless($ptr, $class);
}

sub DESTROY {
  my $self = shift;

  # disabled because of buggy nature of CL interface
  #  CWB::CL::cl_delete_attribute($self->{'ptr'});
}


sub max_alg ( $ ) {
  my $self = shift;
  my $size = CWB::CL::cl_max_alg($self);
  if ($size < 0) {
    croak CWB::CL::error_message()." (aborted)"
      if CWB::CL::strict();
    return undef;
  }
  return $size;
}

sub has_extended_alignment ( $ ) {
  my $self = shift;
  my $yesno = CWB::CL::cl_has_extended_alignment($self);
  if ($yesno < 0) {
    croak CWB::CL::error_message()." (aborted)"
      if CWB::CL::strict();
    return undef;
  }
  return $yesno;
}

*cpos2alg = \&CWB::CL::cl_cpos2alg;

*alg2cpos = \&CWB::CL::cl_alg2cpos;

*cpos2alg2cpos = \&CWB::CL::cl_cpos2alg2cpos; # convenience function combines cpos2alg() and alg2cpos()


#
#  ------------  CWB::CL::Corpus objects  ------------
#

# $corpus = new CWB::CL::Corpus "name";
# $lemma = $corpus->attribute("lemma", 'p');     # returns CWB::CL::Attribute object (positional attribute)
# $article = $corpus->attribute("article", 's'); # returns CWB::CL::AttStruc object  (structural attribute)
# $french = $corpus->attribute("name-french", 'a');  # returns CWB::CL::AttAlign     (alignment attribute)
# undef $corpus;                                 # delete corpus from memory

package CWB::CL::Corpus;
use Carp;

sub new {
  my $class = shift;
  my $corpusname = shift;
  my $self = {};

  # try to open corpus (corpus name needs to be all lowercase)
  $corpusname = uc($corpusname); # 'official' notation is all uppercase ...
  my $ptr = CWB::CL::cl_new_corpus(
      (defined $CWB::CL::Registry) ? $CWB::CL::Registry : CWB::CL::cl_standard_registry(),
      lc($corpusname)  # ... but CL API requires corpus name in lowercase
    );
  unless (defined $ptr) {
    croak("Can't access corpus $corpusname (aborted)")
      if CWB::CL::strict(); # CL library doesn't set error code in cl_new_corpus() function
    return undef;
  }
  $self->{'ptr'} = $ptr;
  $self->{'name'} = $corpusname;
  return bless($self, $class);
}

sub DESTROY {
  my $self = shift;

  # disabled because of buggy nature of CL interface
  #   CWB::CL::cl_delete_corpus($self->{'ptr'});
}

sub attribute {
  my $self = shift;
  my $name = shift;
  my $type = shift;

  if ($type eq 'p') {
    return (new CWB::CL::PosAttrib $self, $name);
  }
  elsif ($type eq 's') {
    return (new CWB::CL::StrucAttrib $self, $name);
  }
  elsif ($type eq 'a') {
    return (new CWB::CL::AlignAttrib $self, $name);
  }
  else {
    croak "USAGE: \$corpus->attribute(\$name, 'p' | 's' | 'a')";
  }
}




package CWB::CL;                        # back to main package for autosplitter's sake
1;
__END__


=head1 NAME

CWB::CL - Perl interface to the low-level Corpus Library of the IMS Open CWB

=head1 SYNOPSIS

  use CWB::CL;

  print "Registry path = ", $CWB::CL::Registry, "\n";
  $CWB::CL::Registry .= ":/home/my_registry";    # add your own registry directory

  # "strict" mode aborts if any error occurs (convenient in one-off scripts)
  CWB::CL::strict(1);                            # or simply load CWB::CL::Strict module
  CWB::CL::set_debug_level('some');              # 'some', 'all' or 'none' (default)

  # CWB::CL::Corpus objects
  $corpus = new CWB::CL::Corpus "HANSARD-EN";    # name of corpus can be upper or lower case
  die "Error: can't access corpus HANSARD-EN"    # all error conditions return undef
    unless defined $corpus;                      #   (checks are not needed in "strict" mode)
  undef $corpus;                                 # currently, mapped memory cannot be freed


  # CWB::CL::Attribute objects (positional attributes)
  $lemma = $corpus->attribute("lemma", 'p');     # returns CWB::CL::Attribute object