File Coverage

blib/lib/DiaColloDB/Corpus.pm
Criterion Covered Total %
statement 18 80 22.5
branch 0 22 0.0
condition 0 33 0.0
subroutine 6 18 33.3
pod 10 12 83.3
total 34 165 20.6


line stmt bran cond sub pod time code
1             ## -*- Mode: CPerl -*-
2             ## File: DiaColloDB::Corpus.pm
3             ## Author: Bryan Jurish <moocow@cpan.org>
4             ## Description: collocation db, source corpus (raw + common API)
5              
6             package DiaColloDB::Corpus;
7 1     1   417 use DiaColloDB::Document;
  1         2  
  1         35  
8 1     1   441 use DiaColloDB::Document::DDCTabs;
  1         3  
  1         39  
9 1     1   418 use DiaColloDB::Document::JSON;
  1         2  
  1         36  
10 1     1   425 use DiaColloDB::Document::Storable;
  1         2  
  1         37  
11             #use DiaColloDB::Document::TCF; ##-- only loaded on request
12 1     1   7 use DiaColloDB::Logger;
  1         2  
  1         16  
13 1     1   4 use strict;
  1         2  
  1         1248  
14              
15             ##==============================================================================
16             ## Globals & Constants
17              
18             our @ISA = qw(DiaColloDB::Logger);
19             our $DCLASS_DEFAULT = 'DDCTabs';
20              
21             ##==============================================================================
22             ## Constructors etc.
23              
24             ## $corpus = CLASS_OR_OBJECT->new(%args)
25             ## + %args, object structure:
26             ## (
27             ## files => \@files, ##-- source files
28             ## dclass => $dclass, ##-- DiaColloDB::Document subclass for loading (default=$DCLASS_DEFAULT)
29             ## dopts => \%opts, ##-- options for $dclass->fromFile()
30             ## cur => $i, ##-- index of current file
31             ## logOpen => $level, ##-- log-level for open(); default='info'
32             ## )
33             sub new {
34 0     0 1   my $that = shift;
35 0   0       my $corpus = bless({
36             files => [],
37             dclass => $DCLASS_DEFAULT,
38             dopts => {},
39             cur => 0,
40             logOpen => 'info',
41              
42             @_, ##-- user arguments
43             },
44             ref($that)||$that);
45 0           return $corpus;
46             }
47              
48             ##==============================================================================
49             ## API: open/close
50              
51             ## $bool = $corpus->open(\@ARGV, %opts)
52             ## + %opts:
53             ## compiled => $bool, ##-- attempt to load Corpus::Compiled object (default=1)
54             ## glob => $bool, ##-- whether to glob arguments
55             ## list => $bool, ##-- whether arguments are file-lists
56             sub open {
57 0     0 1   my ($corpus,$sources,%opts) = @_;
58 0 0         $corpus = $corpus->new() if (!ref($corpus));
59 0           @$corpus{keys %opts} = values %opts;
60              
61             ##-- check for pre-compiled corpora (single-arguments)
62 0 0 0       if ($opts{compiled} || (!exists($opts{compiled})
      0        
      0        
      0        
      0        
63             && UNIVERSAL::isa($sources,'ARRAY')
64             && @$sources==1
65             && !$opts{list}
66             #&& !$opts{glob}
67             && -e "$sources->[0]/header.json"
68             )) {
69 0           require DiaColloDB::Corpus::Compiled;
70 0           bless($corpus,'DiaColloDB::Corpus::Compiled');
71 0           return $corpus->open($sources,%opts);
72             }
73              
74 0 0         @{$corpus->{files}} = $corpus->{glob} ? (map {glob($_)} @$sources) : @$sources;
  0            
  0            
75 0 0         if ($corpus->{list}) {
76             ##-- read file-lists
77 0           my $listfiles = $corpus->{files};
78 0           $corpus->{files} = [];
79 0           foreach my $listfile (@$listfiles) {
80 0 0         CORE::open(my $fh, "<$listfile")
81             or $corpus->logconfess("open failed for list-file '$listfile': $!");
82 0   0       push(@{$corpus->{files}}, grep {($_//'') ne ''} map {chomp; $_} <$fh>);
  0            
  0            
  0            
  0            
83 0           CORE::close($fh);
84             }
85             }
86 0           $corpus->{cur} = 0;
87              
88             ##-- setup document-class
89 0           $corpus->{dclass} = $corpus->dclass();
90             $corpus->logwarn("open(): can't resolve DiaColloDB::Document subclass for {dclass} argument '$corpus->{dclass}'")
91 0 0         if (!UNIVERSAL::isa($corpus->{dclass},'DiaColloDB::Document'));
92 0           $corpus->vlog($corpus->{logOpen}, "using document parser class $corpus->{dclass}");
93              
94 0           return $corpus;
95             }
96              
97             ## $class = $corpus->dclass()
98             ## + gets fully qualified input document class
99             sub dclass {
100 0 0 0 0 0   return $_[0]{dclass} if (ref($_[0]) && UNIVERSAL::isa($_[0]{dclass},'DiaColloDB::Document'));
101              
102             ##-- setup document-class
103 0           my $corpus = shift;
104 0   0       my $dclass = $corpus->{dclass} || 'DDCTabs';
105 0           foreach my $prefix ('','DiaColloDB::','DiaColloDB::Document::') {
106 0           my $tryclass = $prefix.$dclass;
107 0 0         if (!UNIVERSAL::isa($tryclass,'DiaColloDB::Document')) {
108             ##-- try loading class
109 0           eval "use $tryclass;";
110             }
111 0 0         if (UNIVERSAL::isa($tryclass,'DiaColloDB::Document')) {
112 0           $dclass = $tryclass;
113 0           last;
114             }
115             }
116 0 0         $corpus->logwarn("open(): can't resolve DiaColloDB::Document subclass for {dclass} argument '$dclass'")
117             if (!UNIVERSAL::isa($dclass,'DiaColloDB::Document'));
118              
119 0           return $dclass;
120             }
121              
122             ## $bool = $corpus->close()
123             sub close {
124 0     0 1   my $corpus = shift;
125 0           $corpus->{files} = [];
126 0           $corpus->{cur} = 0;
127 0           return $corpus;
128             }
129              
130             ##==============================================================================
131             ## API: iteration
132              
133             ## $nfiles = $corpus->size()
134             sub size {
135 0     0 1   return scalar(@{$_[0]{files}});
  0            
136             }
137              
138             ## undef = $corpus->ibegin()
139             ## + reset iterator
140             sub ibegin {
141 0     0 1   $_[0]{cur}=0;
142             }
143              
144             ## $bool = $corpus->iok()
145             ## + true if iterator is valid
146             sub iok {
147 0     0 1   return $_[0]{cur} <= $#{$_[0]{files}};
  0            
148             }
149              
150             ## $label = $corpus->ifile()
151             ## $label = $corpus->ifile($pos)
152             ## + current iterator label
153             sub ifile {
154 0   0 0 1   return $_[0]{files}[$_[1]//$_[0]{cur}];
155             }
156              
157             ## $doc_or_undef = $corpus->idocument()
158             ## $doc_or_undef = $corpus->idocument($pos)
159             ## + gets current document
160             sub idocument {
161 0     0 1   my ($corpus,$pos) = @_;
162 0   0       $pos //= $corpus->{cur};
163 0 0         return undef if ($pos > $#{$corpus->{files}});
  0            
164 0   0       return $corpus->{dclass}->fromFile($corpus->{files}[$pos], %{$corpus->{dopts}//{}});
  0            
165             }
166              
167             ## $pos = $corpus->inext()
168             ## + increment iterator
169             sub inext {
170 0     0 1   ++$_[0]{cur};
171             }
172              
173             ## $pos = $corpus->icur()
174             ## + returns current position
175             sub icur {
176 0     0 1   return $_[0]{cur};
177             }
178              
179             ##==============================================================================
180             ## API: compilation
181              
182             ## $compiled_corpus = $src_corpus->compile($compiled_dbdir, %opts)
183             ## + wrapper for DiaColloDB::Corpus::Compiled->create($src_corpus, %opts, dbdir=>$compiled_dbdir)
184             sub compile {
185 0     0 0   my ($corpus,$odir,%opts) = @_;
186 0           require DiaColloDB::Corpus::Compiled;
187 0           return DiaColloDB::Corpus::Compiled->create($corpus, %opts, dbdir=>$odir);
188             }
189              
190              
191             ##==============================================================================
192             ## Footer
193             1;
194              
195             __END__
196              
197              
198              
199