File Coverage

blib/lib/Text/Thesaurus/ISO.pm

Criterion	Covered	Total	%
statement	6	149	4.0
branch	0	54	0.0
condition	0	3	0.0
subroutine	2	15	13.3
pod	13	13	100.0
total	21	234	8.9

#
# ROADS Thesaurus Object
#
# Author: [e-mail]
#
# $Id: ISO.pm,v 1.4 1998/10/21 13:31:40 jon Exp jon $
#

package Text::Thesaurus::ISO;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
require Exporter;
@ISA = qw(Exporter AutoLoader);
$VERSION = "1.0";

my($debug) = 0; # turn debugging off normally

# Constructor method
sub new {
   my $this = shift;
   my $isofile = @_;
   my $class = ref($this) || $this;
   my $self = {};
   bless $self, $class;

   if(defined($isofile)) {
     $self->open($isofile);
   }
   return $self;
}

# method to open a theasaurus
sub open {
  my($self) = shift;
  my($isofile) = @_;

  if(!dbmopen(%{$$self{"termdbm"}} ,"$isofile.term",undef)) {
    $self->reopen($isofile);
  } else {
    CORE::open(THESFILE,$isofile) || return(undef);
    dbmopen(%{$$self{"broaddbm"}} ,"$isofile.broad",0666);
  }
}

# method to reopen a theasaurus, rebuilding the database structures.
sub reopen {
  my($self) = shift;
  my($isofile) = @_;
  my($first,$line,$term,@terms,$position,@broadterms,$mainterm);

  CORE::open(THESFILE,$isofile) || return(undef);
  dbmopen(%{$$self{"termdbm"}} ,"$isofile.term",0666);
  dbmopen(%{$$self{"broaddbm"}} ,"$isofile.broad",0666);
  warn "About to undef DBM files\n" if($debug);
  undef(%{$$self{"termdbm"}});
  undef(%{$$self{"broaddbm"}});
  warn "Done undef DBM files\n" if($debug);
  $first = 0;
  while($line = ) {
    $line =~ s/[\n\r]//g;
    if($line eq "\$\$") {
      if($first) {
        foreach $term (@terms) {
          $term=~s/^\s+//;
          $term=~s/\s+$//;
          warn "Adding $term to termdbm\n" if($debug);
          $$self{"termdbm"}->{"$term"} = $position;
        }
        foreach $term (@broadterms) {
          $term=~s/^\s+//;
          $term=~s/\s+$//;
          warn "Adding $term to broaddbm\n" if($debug);
          if(!defined($$self{"broaddbm"}->{"$term"})){
            $$self{"broaddbm"}->{"$term"} = $mainterm;
          } else {
            $$self{"broaddbm"}->{"$term"} =
              $$self{"broaddbm"}->{"$term"}.",$mainterm";
          }
        }
      }
      $first = 1;
      $position = tell THESFILE;
      warn "Position is now $position\n" if($debug);
      $mainterm = "";
      @terms = ();
      @broadterms = ();
    } elsif ($line =~ /TERM\s+(.*)/) {
      push(@terms,$1);
      $mainterm = $1;
    } elsif ($line =~ /ALT\s+(.*)/) {
      my($alt) = $1;
      $alt =~ s/^\s*ALTERNATE:\s*//;
      push(@terms,$alt);
    } elsif ($line =~ /UKALT\s+(.*)/) {
      my($alt) = $1;
      $alt =~ s/^\s*UK ALTERNATE:\s*//g;
      push(@terms,$alt);
    } elsif ($line =~ /UK\s+(.*)/) {
      my($alt) = $1;
      $alt =~ s/^\s*UK:\s*//g;
      push(@terms,$alt);
    } elsif ($line =~ /UF\s+(.*)/) {
      push(@terms,$1);
    } elsif ($line =~ /BT\s+(.*)/) {
      push(@broadterms,$1);
    }
  }
}

# method to get details of an input term
sub terminfo {
  my($self) = shift;
  my($inputterm) = @_;
  my($position,$line);
  my(%thesaurusrecord);

  $position = $$self{"termdbm"}->{"$inputterm"};
  warn "Position for term $inputterm is $position\n" if($debug);
  seek(THESFILE,$position,0);
  while($line = ) {
    $line =~ s/[\r\n]+$//;
    if($line =~ /^\$\$/) {
      last;
    }
    if ($line =~ /([a-zA-Z0-9]+)\s+(.*)/) {
      my($attrib) = $1;
      my($value) = $2;

      $value =~ s/^ALTERNATE:\s*// if($attrib eq "ALT");
      $value =~ s/^SCOPE NOTE:\s*// if($attrib eq "SN");
      $value =~ s/^UK ALTERNATE:\s*// if($attrib eq "UKALT");
      if(!defined($thesaurusrecord{"$attrib"})) {
        $thesaurusrecord{"$attrib"} = $value;
      } else {
        my($old) =  $thesaurusrecord{"$attrib"};
        $thesaurusrecord{"$attrib"} = "$old\n$value";
      }
    }
  }

  return(%thesaurusrecord);

}

# method to get a list of broader terms from an input term
sub broader {
  my($self) = shift;
  my($inputterm) = @_;
  my(%fullrecord);

  %fullrecord = $self->terminfo($inputterm);
  return(split("\n",$fullrecord{"BT"}));
}

# method to get a list of narrower terms from an input term
sub narrower {
  my($self) = shift;
  my($inputterm) = @_;

  return(split(",",$$self{"broaddbm"}->{"$inputterm"}));
}

# method to return the date that the record was entered
sub dateentered {
  my($self) = shift;
  my($inputterm) = @_;
  my(%record);

  %record = $self->terminfo($inputterm);
  if(defined($record{"DATENT"})) {
    return($record{"DATENT"});
  } else {
    return(undef);
  }
}

# method to return the date that the record was last changed
sub datechanged {
  my($self) = shift;
  my($inputterm) = @_;
  my(%record);

  %record = $self->terminfo($inputterm);
  if(defined($record{"DATCHG"})) {
    return($record{"DATCHG"});
  } else {
    return(undef);
  }
}

# method to get a list of alternatives terms from an input term
sub alternatives {
  my($self) = shift;
  my($inputterm) = @_;
  my(%record);
  my(@alternatives);

  %record = $self->terminfo($inputterm);
  @alternatives = split("\n",$record{"TERM"});
  push(@alternatives, split("\n",$record{"ALT"}));
  push(@alternatives, split("\n",$record{"UK"}));
  push(@alternatives, split("\n",$record{"UF"}));
  return(@alternatives);
}

# method to return a list of source information statements
sub sources {
  my($self) = shift;
  my($inputterm) = @_;
  my(%record);
  my(@sources);

  %record = $self->terminfo($inputterm);
  @sources = split("\n",$record{"SOURCE"});
  return(@sources);
}

# method to return a list of links to other terms
sub links {
  my($self) = shift;
  my($inputterm) = @_;
  my(%record);
  my(@links);

  %record = $self->terminfo($inputterm);
  @links = split("\n",$record{"LINK"});
  return(@links);
}

# method to return the scope note, which usually describes the term in
# natural language.
sub scopenote {
  my($self) = shift;
  my($inputterm) = @_;
  my(%record);
  my(@sn);

  %record = $self->terminfo($inputterm);
  @sn = split("\n",$record{"SN"});
  return(@sn);
}

# method to return the history behind a term's entry in the thesaurus
sub history {
  my($self) = shift;
  my($inputterm) = @_;
  my(%record);
  my(@sn);

  %record = $self->terminfo($inputterm);
  @sn = split("\n",$record{"HN"});
  return(@sn);
}

1;
__END__