| Peter Harders | d892a58 | 2020-02-12 15:45:22 +0100 | [diff] [blame] | 1 | ##!/usr/local/bin/perl -w |
| 2 | ##!/usr/local/bin/perl -w -C 7 # STDIN, STDOUT and STDERR will be in UTF-8 (see 'man perlrun') |
| 3 | |
| 4 | ## see TODOs |
| 5 | |
| 6 | ### NOTES: |
| 7 | ### |
| 8 | ### 1. The input for this file has to be UTF8-encoded _without_ SGML-Entites (except the escaped ones -> &amp;, <lt;, >gt;, 'apos;, "quot; |
| 9 | ### - XML::LibXML::Reader translates them back to their origin - e.g.: &amp; -> & (because '&' translates to '&'). |
| 10 | ### SGML-Entities cannot be processed, because of the first 2 missing lines in the input document (see xces2korap.sh). |
| 11 | ### |
| 12 | ### 2. Let 'data.xml' only be used/referred by 'sentences.xml', 'paragraphs.xml' and 'structure.xml', since it can contain double blanks (' ' - see comment to '<s/>' in func. |
| 13 | ### retr_info) and TODO: also contains not only text inside s-tags (e.g.: <label><hi rend="it bo">Ludwig Pietsch (1824-1911):</hi></label><item><s>Journalist ...) |
| 14 | ### |
| 15 | |
| 16 | |
| 17 | use 5.012; |
| 18 | |
| 19 | use strict; |
| 20 | use warnings; |
| 21 | use File::Basename; # dirname |
| 22 | use IO::Handle qw( ); |
| 23 | use IO::Select; |
| 24 | |
| 25 | use open qw(:std :utf8); # assume utf-8 encoding |
| 26 | use Encode qw(encode_utf8 decode_utf8); |
| 27 | |
| 28 | use Getopt::Long; |
| 29 | use XML::CompactTree::XS; |
| 30 | use XML::LibXML::Reader; |
| 31 | use IO::Compress::Zip qw(zip $ZipError :constants); |
| 32 | use IPC::Open2; # open2 |
| 33 | |
| 34 | my $zip; my $first_write=1; |
| 35 | my $outh = *STDOUT; |
| 36 | |
| 37 | my $_CORR_POS_FOR_EMPTY_S_TAGS = 1; # this should only be deactivated for test purposes (empty s-tags produce an additional blank (look for ' ' in data.xml) |
| 38 | my $_CORR_BYTE_POS_FOR_P_TAGS = 1; |
| 39 | |
| Peter Harders | 7025713 | 2020-02-13 13:47:55 +0100 | [diff] [blame^] | 40 | my $_GEN_TOK_BAS = 0; |
| Peter Harders | d892a58 | 2020-02-12 15:45:22 +0100 | [diff] [blame] | 41 | my $_GEN_TOK_DUMMY = 0; # not needed for drukola or cmc |
| 42 | |
| 43 | my $_COMPRESSION_METHOD = ZIP_CM_DEFLATE; |
| 44 | |
| 45 | my $_DEBUG = 0; |
| 46 | |
| 47 | my $_root_dir = "."; # output base directory |
| 48 | my $_header_file = "header.xml"; # filename to save text header in (in Latin1 format -> needed for ... ?) # TODO: why 'Latin1'? |
| 49 | my $_data_file = "data.xml"; # filename to save text data in (in UTF-8 format -> needed for ... ?) |
| 50 | my $_base_dir = "base"; # directory to store sentence and paragraph file and ... |
| 51 | my $_structure_dir = "struct"; |
| 52 | my $_structure_file = "structure.xml"; |
| 53 | my ($text_id, $text_id_esc); # '$text_id_esc' = escaped version of $text_id - see %ent (needed e.g. for 'Corola-PublishingHouse/Editura "Cronica"/260_a_608') |
| 54 | my $dir = ""; # text directory (on top of base) |
| 55 | my $dir_crp = ""; # corpus directory (on top of base) |
| 56 | my $dir_doc = ""; # document directory (on top of base) |
| 57 | my $data = ""; # $data is written to '$_data_file' |
| 58 | my %ent=('"', '"', '&','&','<','<','>','>'); # convert '&', '<' and '>' to their corresp. sgml-entities for compat. with KorAP |
| 59 | # NOTE: the index still refers to the above char-versions, which are counted as 1 |
| 60 | # (search for '&' in data.xml and see corresp. indices in structure.xml, lemma.xml, ana.xml ...) |
| 61 | my $header_crp = ""; |
| 62 | my $header_doc = ""; |
| 63 | my $header_txt = ""; # $header_* are written to '$_header_file' |
| 64 | |
| 65 | my ($header_fl_crp, $header_fl_doc, $header_fl_txt, $data_fl, $header_prfx, $data_prfx1, $data_prfx2, $data_sfx); |
| 66 | $header_prfx = $data_prfx1 = $data_prfx2 = $data_sfx = ""; |
| 67 | |
| 68 | my ($i, $c); |
| 69 | |
| 70 | ### needed for sub retr_info |
| 71 | my $_XCT_LN=0; # remember line numbers (set to 1 if debugging) |
| 72 | my ($reader, $tree_data, $rl, $_IDX, $n, $e, $dl, @oti); |
| 73 | # 'dl' stands for 'data length', 'oti' stands for 'open tags index' |
| 74 | ($_XCT_LN)?($_IDX=5):($_IDX=4); |
| 75 | ### |
| 76 | ### needed in func. write_structures |
| 77 | my ($ref, $idx, $att_idx); |
| 78 | |
| 79 | my $buf_in = ""; |
| 80 | my $output; |
| 81 | |
| 82 | ### needed for tokenization |
| 83 | my $_tok_file_bas = "tokens.xml"; |
| 84 | |
| 85 | #my @sentences; # sentence character offsets (start, end, start, end, ...) |
| 86 | #my @paragraphs; # paragraph character offsets (start, end, start, end, ...) |
| 87 | my @structures; # list of hashes, each hash representing an XML element |
| 88 | |
| 89 | ## whitespace-related issue (see retr_info()): needed to correct from-offset for some tags |
| 90 | my $add_one; |
| 91 | my %hws; # hash for indices of whitespace nodes (needed to recorrect from-value) |
| 92 | # idea: when closing element, check if it's from-index minus 1 refers to a whitespace node (means: 'from-index - 1' is a key in %hws). |
| 93 | # if this is _not_ the case, then the from-value is one to high => correct it by substracting 1 |
| 94 | my ($fval, $fval2); |
| 95 | $fval=$fval2=0; # init. |
| 96 | ## |
| 97 | |
| 98 | ## needed if $_GEN_TOK_DUMMY is set |
| 99 | my $_tok_file_con = "tokens_conservative.xml"; |
| 100 | my $_tok_file_agg = "tokens_aggr.xml"; |
| 101 | my (@tok_tokens_con, @tok_tokens_agg); |
| 102 | my ($m1, $m2, $m3, $m4, $tmp, $p1, $p2, $pr, $offset, $txt); |
| 103 | $offset=0; |
| 104 | ## |
| 105 | |
| 106 | # do this to prevent error message 'Global symbol "..." requires explicit package name at ...' |
| 107 | my ($_ANNOT_ATT_ANNOT_NAME_RD, $_ANNOT_ATT_LEM_NAME_RD, $_ANNOT_ATT_POS_NAME_WR, $_ANNOT_ATT_MSD_NAME_WR) = ('','','',''); |
| 108 | |
| 109 | ## needed for handling some inline annotations |
| 110 | my $_ANNOT_GEN = 0; # turn processing of inline annotations on/off |
| 111 | #my $_ANNOT_DIR_NAME = "connexor"; # name of path/foundry to write information to |
| 112 | my $_ANNOT_DIR_NAME = "drukola"; # name of path/foundry to write information to |
| 113 | #my $_ANNOT_DIR_NAME = "cmc"; # name of path/foundry to write information to # cmc = computer mediated communication - needed for dck corpus |
| 114 | my $_ANNOT_FILE_NAME = "morpho.xml"; # file to write annotations to |
| 115 | my $_ANNOT_TAG_NAME_RD = "w"; # from which tag to fetch the below attributes |
| 116 | $_ANNOT_ATT_ANNOT_NAME_RD = "ana"; # from which attribute to fetch the msd and pos information |
| 117 | #$_ANNOT_ATT_ANNOT_NAME_RD = "type"; # from which attribute to fetch the msd and pos information # must be 'type' for dck corpus |
| 118 | # new: comment out, if not needed |
| 119 | $_ANNOT_ATT_LEM_NAME_RD = "lemma"; # from which attribute to fetch the lemma information |
| 120 | # new: comment out, if not needed |
| 121 | $_ANNOT_ATT_POS_NAME_WR = "pos"; # see e.g.: GIT/KorAP-XML-Krill/t/annotation/corpus/doc/0001/mate/morpho.xml |
| 122 | # new: comment out, if not needed |
| 123 | $_ANNOT_ATT_MSD_NAME_WR = "msd"; # not needed for dck corpus |
| 124 | # new: comment out, if not needed |
| 125 | my $_ANNOT_ATT_LEM_NAME_WR = "lemma"; # s.a. |
| 126 | my (@annot, @oti2); |
| 127 | my $inside_annot_tag = -1; |
| 128 | ## |
| 129 | |
| 130 | my $help; |
| 131 | |
| 132 | GetOptions( |
| 133 | "base=s" => \$_root_dir, |
| 134 | "help" => \$help |
| 135 | ); |
| 136 | |
| 137 | printhelp() if $help; |
| 138 | |
| 139 | ###### |
| 140 | ###### MAIN |
| 141 | ###### |
| 142 | $_root_dir.='/'; # must always end with a slash at this point |
| 143 | $_root_dir=~s/^\.?\///; # remove leading / (only relative paths allowed in IO::Compress::Zip) and ./ |
| 144 | |
| 145 | my $lc=0; my $tc=0; my ($pfx, $sfx); |
| 146 | $header_fl_txt=0; |
| 147 | |
| 148 | # header_prfx |
| 149 | $header_prfx = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"; |
| 150 | $header_prfx .= "<?xml-model href=\"header.rng\" type=\"application/xml\" schematypens=\"http://relaxng.org/ns/structure/1.0\"?>\n"; |
| 151 | $header_prfx .= "<!DOCTYPE idsCorpus PUBLIC \"-//IDS//DTD IDS-XCES 1.0//EN\" \"http://corpora.ids-mannheim.de/idsxces1/DTD/ids.xcesdoc.dtd\">\n"; |
| 152 | |
| 153 | $data_prfx1 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"; |
| 154 | $data_prfx1 .= "<?xml-model href=\"text.rng\" type=\"application/xml\" schematypens=\"http://relaxng.org/ns/structure/1.0\"?>\n\n"; |
| 155 | $data_prfx1 .= "<raw_text docid=\""; |
| 156 | $data_prfx2 .= "\" xmlns=\"http://ids-mannheim.de/ns/KorAP\">\n"; |
| 157 | $data_prfx2 .= " <metadata file=\"metadata.xml\" />\n"; |
| 158 | $data_prfx2 .= " <text>"; |
| 159 | $data_sfx = "</text>\n</raw_text>"; |
| 160 | |
| 161 | my($chld_out, $chld_in, $pid, $select); |
| 162 | if( $_GEN_TOK_BAS ){ |
| 163 | startTokenizer(); |
| 164 | } |
| 165 | |
| 166 | while(<STDIN>){ |
| 167 | |
| 168 | $lc++; # line counter |
| 169 | |
| 170 | if( $data_fl && m/^(.+)?<\/text>(.+)?$/ ){ # end of text body |
| 171 | ### |
| 172 | ### write data.xml, sentences.xml, paragraph.xml and structure.xml |
| 173 | ### |
| 174 | |
| 175 | $pfx=$1; $sfx=$2; |
| 176 | die "ERROR ($0): main(): input line number $lc: line with closing tag for 'text' contains additional information ... => Aborting\n\tline=$_" |
| 177 | if (defined $pfx && $pfx !~ /^\s*$/) || (defined $sfx && $sfx !~ /^\s*$/); |
| 178 | |
| 179 | if( $dir ne "" ){ |
| 180 | |
| 181 | ### NOTE: needed for debugging (e.g. whitespace issues) |
| 182 | #if( $text_id eq "GOE_AGA.00000" ) |
| 183 | #if( $text_id eq "GOE_AGI.04846" ) |
| 184 | #{ |
| 185 | #open H1, ">/tmp/t123"; |
| 186 | #print H1 "$buf_in"; |
| 187 | #close H1; |
| 188 | #} |
| 189 | #### |
| 190 | |
| 191 | $reader = XML::LibXML::Reader->new(string => "<text>$buf_in</text>", huge => 1); |
| 192 | |
| 193 | if( $_XCT_LN ){ # _XCT_LINE_NUMBERS is only for debugging |
| 194 | #$tree_data = XML::CompactTree::XS::readSubtreeToPerl($reader, XCT_DOCUMENT_ROOT|XCT_IGNORE_WS|XCT_IGNORE_SIGNIFICANT_WS|XCT_IGNORE_COMMENTS|XCT_ATTRIBUTE_ARRAY|XCT_LINE_NUMBERS); |
| 195 | # remove 'XCT_IGNORE_WS', because whitespace (in form of one blank) between tags is needed for separation of 'text-nodes' in data.xml |
| 196 | # TODO: check out the meanings/differences of 'XCT_IGNORE_WS' and 'XCT_IGNORE_SIGNIFICANT_WS': seems like, 'XCT_IGNORE_SIGNIFICANT_WS' is the one we need |
| 197 | $tree_data = XML::CompactTree::XS::readSubtreeToPerl($reader, XCT_DOCUMENT_ROOT|XCT_IGNORE_COMMENTS|XCT_ATTRIBUTE_ARRAY|XCT_LINE_NUMBERS); |
| 198 | # $tree_data = XML::CompactTree::XS::readSubtreeToPerl($reader, XCT_DOCUMENT_ROOT|XCT_IGNORE_COMMENTS|XCT_ATTRIBUTE_ARRAY|XCT_IGNORE_WS|XCT_IGNORE_SIGNIFICANT_WS|XCT_LINE_NUMBERS); |
| 199 | }else{ |
| 200 | $tree_data = XML::CompactTree::XS::readSubtreeToPerl($reader, XCT_DOCUMENT_ROOT|XCT_IGNORE_COMMENTS|XCT_ATTRIBUTE_ARRAY); |
| 201 | # $tree_data = XML::CompactTree::XS::readSubtreeToPerl($reader, XCT_DOCUMENT_ROOT|XCT_IGNORE_COMMENTS|XCT_ATTRIBUTE_ARRAY|XCT_IGNORE_WS|XCT_IGNORE_SIGNIFICANT_WS); |
| 202 | } |
| 203 | |
| 204 | @structures=(); @oti=(); |
| 205 | |
| 206 | if( $_ANNOT_GEN ){ |
| 207 | @annot=(); @oti2=() |
| 208 | } |
| 209 | |
| 210 | $dl = 0; |
| 211 | |
| 212 | $rl = 0; # recursion level |
| 213 | |
| 214 | # whitespace related issue |
| 215 | $add_one = 0; |
| 216 | %hws=(); |
| 217 | # |
| 218 | |
| 219 | ### |
| 220 | ### recursion |
| 221 | retr_info( \$tree_data->[2] ); # parse input data |
| 222 | ### |
| 223 | ### |
| 224 | $rl--; |
| 225 | |
| 226 | # write data.xml |
| 227 | $data=~tr/\n\r/ /; # NOTE: 2 blanks - otherwise offset data would become corrupt |
| 228 | $data=encode_utf8($data); |
| 229 | |
| 230 | # first write it to tokenization pipe to give it some time |
| 231 | if( $_GEN_TOK_BAS ){ |
| 232 | print $chld_in "$data\n\x03\n"; |
| 233 | } |
| 234 | |
| 235 | print STDERR "DEBUG ($0): main(): Writing (utf8-formatted) xml file $_root_dir$dir/$_data_file\n" if $_DEBUG; |
| 236 | if ($first_write){ |
| 237 | $first_write=0; |
| 238 | ### 1st time: create instance |
| Peter Harders | 7025713 | 2020-02-13 13:47:55 +0100 | [diff] [blame^] | 239 | $zip = new IO::Compress::Zip $outh, Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 0, Name => "$_root_dir$dir/$_data_file" |
| Peter Harders | d892a58 | 2020-02-12 15:45:22 +0100 | [diff] [blame] | 240 | or die "ERROR ('$_root_dir$dir/$_data_file'): zip failed: $ZipError\n" |
| 241 | }else{ |
| 242 | ### close previous stream and open new one |
| 243 | $zip->newStream( Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 1, Name => "$_root_dir$dir/$_data_file" ) |
| 244 | or die "ERROR ('$_root_dir$dir/$_data_file'): zip failed: $ZipError\n" |
| 245 | } |
| 246 | $data =~ s/(&|<|>)/$ent{$1}/g; |
| 247 | $zip->print("$data_prfx1$text_id_esc$data_prfx2$data$data_sfx"); |
| 248 | |
| 249 | # write structures |
| 250 | write_structures() if @structures; |
| 251 | |
| 252 | # write annotations |
| 253 | write_annot() if $_ANNOT_GEN && @annot; |
| 254 | |
| 255 | # tokenization |
| 256 | if( $_GEN_TOK_BAS || $_GEN_TOK_DUMMY ) |
| 257 | { |
| 258 | write_tok(); |
| 259 | if( $_GEN_TOK_DUMMY ){ |
| 260 | $offset = 0; @tok_tokens_con=(); @tok_tokens_agg=(); |
| 261 | } |
| 262 | } |
| 263 | |
| 264 | $data_fl=0; $data = $dir = $buf_in = ""; # reinit. |
| 265 | |
| 266 | }else{ # $dir eq "" |
| 267 | |
| 268 | print STDERR "WARNING ($0): main(): maybe empty textSigle => skipping this text ...\n"; |
| 269 | print STDERR "WARNING ($0): main(): text header=$header_txt\n"; |
| 270 | print STDERR "WARNING ($0): main(): data=$data\n"; |
| 271 | } |
| 272 | }elsif( $data_fl ){ # inside text body |
| 273 | #print STDERR "inside text body (\$data_fl set)\n"; |
| 274 | |
| 275 | ### whitespace handling |
| 276 | # remove consecutive whitespace at beginning and end (mostly one newline) |
| 277 | # to let 'XML::CompactTree::XS' recognize these blanks as 'text-nodes', the option 'XCT_IGNORE_WS' may not be used (see above). |
| 278 | s/^\s+//; s/\s+$//; |
| 279 | |
| 280 | # important!: search for '>[^<][^<]*<' e.g. in 'vim goe_tagged.i5.xml.bz2' => insert a blank before every _first_ tag in a line, that contains text |
| 281 | # NOTE: the input text should avoid structures like below (which could also happen to other tags like '<pb ... />' or '<abbr>' etc.): |
| 282 | # negative example for '<w>' (see dck corpus in 'DeReKo-2016-II' - H.L. will fix this in 'DeReKo-2017-I'): |
| 283 | # <s> |
| 284 | # ... |
| 285 | # <w id="f1306078.m10.t9" lemma="zu" type="APPRART">zur</w> |
| 286 | # <w id="f1306078.m10.t10" lemma="Kenntnis" type="NN">Kenntnis</w> |
| 287 | # <w id="f1306078.m10.t11" lemma="nehmen" type="VVINF">nehmen</w> |
| 288 | # <w id="f1306078.m10.t12" lemma="," type="$,">,</w> |
| 289 | # <w id="f1306078.m10.t13" lemma="dass" type="KOUS">dass</w> |
| 290 | # ... |
| 291 | # In the above example, the whitespace/blank information between the words is lost. The below perl subst. expression does not recognize, that there may not be a blank before a comma. |
| 292 | if(m/<[^>]+>[^<]/){ |
| 293 | $tc++; # text counter |
| 294 | s/^(.)/ $1/ if $tc>1; # only add a blank, if this is not the first text in the whole text |
| 295 | } |
| 296 | |
| 297 | # add line to buffer |
| 298 | $buf_in .= $_; |
| 299 | |
| 300 | }elsif( $header_fl_txt && m/^(.*<\/idsHeader>)(.+)?$/ ){ # end of text header |
| 301 | #print STDERR "end of text header\n"; |
| 302 | ### |
| 303 | ### write header.xml |
| 304 | ### |
| 305 | $header_txt .= $1; $header_fl_txt = 0; $sfx=$2; |
| 306 | die "ERROR ($0): main(): input line number $lc: line with closing tag for 'idsHeader type=\"text\"' contains additional information ... => Aborting\n\tline=$_" |
| 307 | if defined $sfx && $sfx !~ /^\s*$/; |
| 308 | if( $dir eq "" ){ |
| 309 | print STDERR "WARNING ($0): main(): input line number $lc: empty textSigle in text header => nothing to do ...\ntext header=$header_txt\n"; |
| 310 | }else{ |
| 311 | print STDERR "DEBUG ($0): Writing file $_root_dir$dir/$_header_file\n" if $_DEBUG; |
| 312 | # create zip buffer |
| 313 | if ($first_write){ |
| 314 | $first_write=0; |
| Peter Harders | 7025713 | 2020-02-13 13:47:55 +0100 | [diff] [blame^] | 315 | $zip = new IO::Compress::Zip $outh, Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 0, Name => "$_root_dir$dir/$_header_file" |
| Peter Harders | d892a58 | 2020-02-12 15:45:22 +0100 | [diff] [blame] | 316 | or die "ERROR ('$_root_dir$dir/$_header_file'): zip failed: $ZipError\n" |
| 317 | }else{ |
| 318 | $zip->newStream( Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 1, Name => "$_root_dir$dir/$_header_file" ) |
| 319 | or die "ERROR ('$_root_dir$dir/$_header_file'): zip failed: $ZipError\n" |
| 320 | } |
| 321 | $header_txt=encode_utf8($header_txt); |
| 322 | $zip->print("$header_prfx$header_txt"); |
| 323 | } |
| 324 | }elsif( $header_fl_txt ){ # inside text header |
| 325 | #print STDERR "inside text header\n"; |
| 326 | if( m/^(.+)?<textSigle>([^<]+)(.+)$/ ){ |
| 327 | $pfx=$1; $sfx=$3; $dir=$2; $text_id = $dir; $text_id =~ tr/\//_/; $dir =~ s/("|&|<|>)/$ent{$1}/g; |
| 328 | $text_id=encode_utf8($text_id); # otherwise problems with "wide character" where $text_id is printed (see e.g.: http://ahinea.com/en/tech/perl-unicode-struggle.html) |
| 329 | # see e.g.: Drukola-Project |
| 330 | die "ERROR ($0): main(): input line number $lc: line with textSigle-tag is not in expected format ... => Aborting\n\tline=$_" |
| 331 | if (defined $pfx && $pfx !~ /^\s*$/) || $sfx !~ /^<\/textSigle>\s*$/; |
| 332 | print STDERR "$0: main(): text_id=".decode_utf8($text_id)."\n"; # some output to see progression |
| 333 | $text_id_esc = $text_id; |
| 334 | if( $text_id_esc =~ s/("|&|<|>)/$ent{$1}/g ){ |
| 335 | $_ =~ s/(<textSigle>)[^<]+(<\/textSigle>)/$1$dir$2/; # do be consistent with escaping, escape also textSigle in Text-Header |
| 336 | } |
| 337 | $dir =~ tr/\./\//; |
| 338 | } |
| 339 | $header_txt .= $_; |
| 340 | }elsif( $header_fl_doc && m/^(.*<\/idsHeader>)(.+)?$/ ){ # end of document header |
| 341 | #print STDERR "end of doc header\n"; |
| 342 | $header_doc .= $1; $header_fl_doc = 0; $sfx=$2; |
| 343 | die "ERROR ($0): main(): input line number $lc: line with closing tag for 'idsHeader type=\"document\"' contains additional information ... => Aborting\n\tline=$_" |
| 344 | if defined $sfx && $sfx !~ /^\s*$/; |
| 345 | if( $dir_doc eq "" ){ |
| 346 | print STDERR "WARNING ($0): main(): input line number $lc: empty document sigle in document header => nothing to do ...\ndocument header=$header_doc\n"; |
| 347 | }else{ |
| 348 | print STDERR "DEBUG ($0): Writing file $_root_dir$dir_doc/$_header_file\n" if $_DEBUG; |
| 349 | if ($first_write){ |
| 350 | $first_write=0; |
| Peter Harders | 7025713 | 2020-02-13 13:47:55 +0100 | [diff] [blame^] | 351 | $zip = new IO::Compress::Zip $outh, Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 0, Name => "$_root_dir$dir_doc/$_header_file" |
| Peter Harders | d892a58 | 2020-02-12 15:45:22 +0100 | [diff] [blame] | 352 | or die "ERROR ('$_root_dir$dir_doc/$_header_file'): zip failed: $ZipError\n" |
| 353 | }else{ |
| 354 | $zip->newStream( Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 1, Name => "$_root_dir$dir_doc/$_header_file" ) |
| 355 | or die "ERROR ('$_root_dir$dir_doc/$_header_file'): zip failed: $ZipError\n" |
| 356 | } |
| 357 | $header_doc=encode_utf8($header_doc); |
| 358 | $zip->print("$header_prfx$header_doc"); |
| 359 | } |
| 360 | }elsif( $header_fl_doc ){ # inside document header |
| 361 | #print STDERR "inside doc header\n"; |
| 362 | if( m/^(.+)?<dokumentSigle>([^<]+)(.+)$/ ){ |
| 363 | $pfx=$1; $sfx=$3; $dir_doc=$2; |
| 364 | die "ERROR ($0): main(): input line number $lc: line with dokumentSigle-tag is not in expected format ... => Aborting\n\tline=$_" |
| 365 | if (defined $pfx && $pfx !~ /^\s*$/) || $sfx !~ /^<\/dokumentSigle>\s*$/; |
| 366 | if( $dir_doc =~ s/("|&|<|>)/$ent{$1}/g ){ |
| 367 | $_ =~ s/(<dokumentSigle>)[^<]+(<\/dokumentSigle>)/$1$dir_doc$2/; # do be consistent with escaping, escape also textSigle in Document-Header |
| 368 | } |
| 369 | } |
| 370 | $header_doc .= $_; |
| 371 | }elsif ( m/^.*(<idsHeader[^>]*type=\"text\".*)$/ ){ # begin of text header |
| 372 | #print STDERR "begin of text header\n"; |
| 373 | $tc=0; ### reset (needed for whitespace-handling) |
| 374 | $header_txt = "$1\n"; $header_fl_txt = 1; |
| 375 | }elsif( m/^(.+)?<text(?: [^>]*)?>(.+)?$/ ){ # begin of text body |
| 376 | #print STDERR "inside text body\n"; |
| 377 | $pfx=$1; $sfx=$2; |
| 378 | die "ERROR ($0): main(): input line number $lc: line with opening tag for 'text' contains additional information ... => Aborting\n\tline=$_" |
| 379 | if (defined $pfx && $pfx !~ /^\s*$/) || (defined $sfx && $sfx !~ /^\s*$/); |
| 380 | $data_fl=1; |
| 381 | }elsif ( m/^.*(<idsHeader[^>]*type=\"document\".*)$/ ){ # begin of document header |
| 382 | #print STDERR "begin of doc header\n"; |
| 383 | $header_doc = "$1\n"; $header_fl_doc = 1; |
| 384 | }elsif( $header_fl_crp && m/^(.*<\/idsHeader>)(.+)?$/ ){ # end of corpus header |
| 385 | #print STDERR "end of corp header\n"; |
| 386 | $header_crp .= $1; $header_fl_crp = 0; $sfx=$2; |
| 387 | die "ERROR ($0): main(): input line number $lc: line with closing tag for 'idsHeader type=\"corpus\"' contains additional information ... => Aborting\n\tline=$_" |
| 388 | if defined $sfx && $sfx !~ /^\s*$/; |
| 389 | if( $dir_crp eq "" ){ |
| 390 | print STDERR "WARNING ($0): main(): input line number $lc: empty corpus sigle in corpus header => nothing to do ...\ncorpus header=$header_crp\n"; |
| 391 | }else{ |
| 392 | print STDERR "DEBUG ($0): Writing file $_root_dir$dir_crp/$_header_file\n" if $_DEBUG; |
| 393 | if ($first_write){ |
| 394 | $first_write=0; |
| Peter Harders | 7025713 | 2020-02-13 13:47:55 +0100 | [diff] [blame^] | 395 | $zip = new IO::Compress::Zip $outh, Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 0, Name => "$_root_dir$dir_crp/$_header_file" |
| Peter Harders | d892a58 | 2020-02-12 15:45:22 +0100 | [diff] [blame] | 396 | or die "ERROR ('$_root_dir$dir_crp/$_header_file'): zip failed: $ZipError\n" |
| 397 | }else{ |
| 398 | $zip->newStream( Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 1, Name => "$_root_dir$dir_crp/$_header_file" ) |
| 399 | or die "ERROR ('$_root_dir$dir_crp/$_header_file'): zip failed: $ZipError\n" |
| 400 | } |
| 401 | $header_crp=encode_utf8($header_crp); |
| 402 | $zip->print("$header_prfx$header_crp"); |
| 403 | } |
| 404 | }elsif( $header_fl_crp ){ # inside corpus header |
| 405 | #print STDERR "inside corp header\n"; |
| 406 | if( m/^(.+)?<korpusSigle>([^<]+)(.+)$/ ){ |
| 407 | $pfx=$1; $sfx=$3; $dir_crp=$2; |
| 408 | die "ERROR ($0): main(): input line number $lc: line with korpusSigle-tag is not in expected format ... => Aborting\n\tline=$_" |
| 409 | if (defined $pfx && $pfx !~ /^\s*$/) || $sfx !~ /^<\/korpusSigle>\s*$/; |
| 410 | if( $dir_crp =~ s/("|&|<|>)/$ent{$1}/g ){ |
| 411 | $_ =~ s/(<korpusSigle>)[^<]+(<\/korpusSigle>)/$1$dir_crp$2/; # do be consistent with escaping, escape also textSigle in Corpus-Header |
| 412 | } |
| 413 | } |
| 414 | $header_crp .= $_; |
| 415 | }elsif ( m/^.*(<idsHeader[^>]*type=\"corpus\".*)$/ ){ # begin of corpus header |
| 416 | #print STDERR "begin of corp header\n"; |
| 417 | $header_crp = "$1\n"; $header_fl_crp = 1; |
| 418 | } |
| 419 | ### |
| 420 | |
| 421 | }#end: while |
| 422 | |
| 423 | if( $_GEN_TOK_BAS ){ |
| 424 | close($chld_in); |
| 425 | close($chld_out); |
| 426 | } |
| 427 | $zip->close(); |
| 428 | |
| 429 | ###### |
| 430 | ###### SUBS |
| 431 | ###### |
| 432 | # |
| 433 | # $reader = XML::LibXML::Reader->new(IO => STDIN); |
| 434 | # $data = XML::CompactTree::XS::readSubtreeToPerl($reader, XCT_DOCUMENT_ROOT|XCT_IGNORE_WS|XCT_IGNORE_SIGNIFICANT_WS|XCT_IGNORE_COMMENTS); |
| 435 | # |
| 436 | # example: <node a=\"v\"><node1>some <n/> text</node1><node2>more-text</node2></node> |
| 437 | # |
| 438 | # ( print out values of above example: echo "<node a=\"v\"><node1>some <n/> text</node1><node2>more-text</node2></node>"|perl -e 'use XML::CompactTree::XS; use XML::LibXML::Reader; $reader = XML::LibXML::Reader->new(IO => STDIN);$data = XML::CompactTree::XS::readSubtreeToPerl($reader,XCT_DOCUMENT_ROOT|XCT_IGNORE_WS|XCT_IGNORE_SIGNIFICANT_WS|XCT_IGNORE_COMMENTS|XCT_LINE_NUMBERS);print $data->[2]->[0]->[5]->[1]->[1]' ) |
| 439 | # |
| 440 | # $data = reference to below array |
| 441 | # |
| 442 | # [ 0: XML_READER_TYPE_DOCUMENT, |
| 443 | # 1: ? |
| 444 | # 2: [ 0: [ 0: XML_READER_TYPE_ELEMENT |
| 445 | # 1: 'node' |
| 446 | # 2: ? |
| 447 | # 3: HASH (attributes) |
| 448 | # 4: 1 (line number) |
| 449 | # 5: [ 0: [ 0: XML_READER_TYPE_ELEMENT |
| 450 | # 1: 'node1' |
| 451 | # 2: ? |
| 452 | # 3: undefined (no attributes) |
| 453 | # 4: 1 (line number) |
| 454 | # 5: [ 0: [ 0: XML_READER_TYPE_TEXT |
| 455 | # 1: 'some ' |
| 456 | # ] |
| 457 | # 1: [ 0: XML_READER_TYPE_ELEMENT |
| 458 | # 1: 'n' |
| 459 | # 2: ? |
| 460 | # 3: undefined (no attributes) |
| 461 | # 4: 1 (line number) |
| 462 | # 5: undefined (no child nodes) |
| 463 | # ] |
| 464 | # 2: [ 0: XML_READER_TYPE_TEXT |
| 465 | # 1: ' text' |
| 466 | # ] |
| 467 | # ] |
| 468 | # ] |
| 469 | # 1: [ 0: XML_READER_TYPE_ELEMENT |
| 470 | # 1: 'node2' |
| 471 | # 2: ? |
| 472 | # 3: undefined (not attributes) |
| 473 | # 4: 1 (line number) |
| 474 | # 5: [ 0: [ 0: XML_READER_TYPE_TEXT |
| 475 | # 1: 'more-text' |
| 476 | # ] |
| 477 | # ] |
| 478 | # ] |
| 479 | # ] |
| 480 | # ] |
| 481 | # ] |
| 482 | # ] |
| 483 | # |
| 484 | # $data->[0] = 9 (=> type == XML_READER_TYPE_DOCUMENT) |
| 485 | # |
| 486 | # ref($data->[2]) == ARRAY (with 1 element for 'node') |
| 487 | # ref($data->[2]->[0]) == ARRAY (with 6 elements) |
| 488 | # |
| 489 | # $data->[2]->[0]->[0] == 1 (=> type == XML_READER_TYPE_ELEMENT) |
| 490 | # $data->[2]->[0]->[1] == 'node' |
| 491 | # ref($data->[2]->[0]->[3]) == HASH (=> ${$data->[2]->[0]->[3]}{a} == 'v') |
| 492 | # $data->[2]->[0]->[4] == 1 (line number) |
| 493 | # ref($data->[2]->[0]->[5]) == ARRAY (with 2 elements for 'node1' and 'node2') NOTE: child nodes of actual node (see $_IDX) |
| 494 | # |
| 495 | # ref($data->[2]->[0]->[5]->[0]) == ARRAY (with 6 elements) |
| 496 | # $data->[2]->[0]->[5]->[0]->[0] == 1 (=> type == XML_READER_TYPE_ELEMENT) |
| 497 | # $data->[2]->[0]->[5]->[0]->[1] == 'node1' |
| 498 | # $data->[2]->[0]->[5]->[0]->[3] == undefined (=> no attribute) |
| 499 | # $data->[2]->[0]->[5]->[0]->[4] == 1 (line number) |
| 500 | # ref($data->[2]->[0]->[5]->[0]->[5]) == ARRAY (with 3 elements for 'some ', '<n/>' and ' text') |
| 501 | # |
| 502 | # ref($data->[2]->[0]->[5]->[0]->[5]->[0]) == ARRAY (with 2 elements) |
| 503 | # $data->[2]->[0]->[5]->[0]->[5]->[0]->[0] == 3 (=> type == XML_READER_TYPE_TEXT) |
| 504 | # $data->[2]->[0]->[5]->[0]->[5]->[0]->[1] == 'some ' |
| 505 | # |
| 506 | # ref($data->[2]->[0]->[5]->[0]->[5]->[1]) == ARRAY (with 5 elements) |
| 507 | # $data->[2]->[0]->[5]->[0]->[5]->[1]->[0] == 1 (=> type == XML_READER_TYPE_ELEMENT) |
| 508 | # $data->[2]->[0]->[5]->[0]->[5]->[1]->[1] == 'n' |
| 509 | # $data->[2]->[0]->[5]->[0]->[5]->[1]->[3] == undefined (=> no attribute) |
| 510 | # $data->[2]->[0]->[5]->[0]->[5]->[1]->[4] == 1 (line number) |
| 511 | # $data->[2]->[0]->[5]->[0]->[5]->[1]->[5] == undefined (=> no child nodes) |
| 512 | # |
| 513 | # ref($data->[2]->[0]->[5]->[0]->[5]->[2]) == ARRAY (with 2 elements) |
| 514 | # $data->[2]->[0]->[5]->[0]->[5]->[2]->[0] == 3 (=> type == XML_READER_TYPE_TEXT) |
| 515 | # $data->[2]->[0]->[5]->[0]->[5]->[2]->[1] == ' text' |
| 516 | # |
| 517 | # |
| 518 | # NOTE: the sub 'retr_info' starts with the array reference '${$_[0]}' (= '\$tree_data->[2]'), which corresponds to '${\$data->[2]}' in the above example. |
| 519 | # Hence, the expression '@{${$_[0]}}' corresponds to '@{${\$data->[2]}', '$e' to '${${\$data->[2]}}[0]' (='$data->[2]->[0]') and '$e->[0]' to '${${\$data->[2]}}[0]->[0]' (='$data->[2]->[0]->[0]'. |
| 520 | |
| 521 | sub retr_info{ |
| 522 | |
| 523 | $rl++; # rec. level (2 = topmost level inside retr_info() = level for all elements directly under <text>) |
| 524 | |
| 525 | # $_[0] is a reference to an array reference |
| 526 | foreach $e( @{${$_[0]}} ){ # iteration through all array elements |
| 527 | |
| 528 | ## http://search.cpan.org/~shlomif/XML-LibXML-2.0118/lib/XML/LibXML/Reader.pod#NODE_TYPES |
| 529 | if( $e->[0] == XML_READER_TYPE_ELEMENT ){ # element node |
| 530 | |
| 531 | ### . insert new array (for new tag) into @structures with tag-name and (if present) tag-attributes |
| 532 | ### . update @oti (open tags indizes) with @structures highest index (=$#structures); e.g.: @a=(1,2,3) => $#a = 2 |
| 533 | ### |
| 534 | $n = $e->[1]; # name of tag |
| 535 | |
| 536 | $inside_annot_tag = $rl if $_ANNOT_GEN && $n eq "$_ANNOT_TAG_NAME_RD"; |
| 537 | |
| 538 | my @array; |
| 539 | push @array, $n; # name of tag |
| 540 | push @structures, \@array; |
| 541 | |
| 542 | push @oti, $#structures; # add highest index of @structures to @oti |
| 543 | |
| 544 | if( $_ANNOT_GEN && $inside_annot_tag == $rl ){ |
| 545 | my @array2; |
| 546 | push @array2, $n; |
| 547 | push @annot, \@array2; |
| 548 | push @oti2, $#annot; |
| 549 | } |
| 550 | |
| 551 | ### handle attributes |
| 552 | if( defined $e->[3] ){ # only go on if attributes exist |
| 553 | for( $c = 0; $c < @{$e->[3]}; $c += 2 ){ # with 'XCT_ATTRIBUTE_ARRAY', $node->[3] is an array reference of the form [ name1, value1, name2, value2, ....] |
| 554 | # of attribute names and corresponding values. NOTE: arrays are faster! (see: http://makepp.sourceforge.net/2.0/perl_performance.html) |
| 555 | |
| 556 | # '$c' references the 'key' and '$c+1' the 'value' (example: perl -e '@a=(X,Y);push @b,\@a;$ref=$b[$#b];push @{$ref},Z;print @{$ref}' => XYZ) |
| 557 | push @{$structures[$#structures]}, ${$e->[3]}[$c], ${$e->[3]}[$c+1]; |
| 558 | |
| 559 | if( $_ANNOT_GEN && $inside_annot_tag == $rl ){ |
| 560 | push @{$annot[$#annot]}, ${$e->[3]}[$c], ${$e->[3]}[$c+1]; |
| 561 | } |
| 562 | } |
| 563 | } |
| 564 | ### |
| 565 | |
| 566 | push @{$structures[$#structures]}, ($dl+$add_one); # from-value |
| 567 | |
| 568 | if( $_ANNOT_GEN && $inside_annot_tag == $rl ){ |
| 569 | push @{$annot[$#annot]}, ($dl+$add_one); |
| 570 | } |
| 571 | |
| 572 | ###### |
| 573 | # until here: opening tag-node |
| 574 | ###### |
| 575 | |
| 576 | ### RECURSION |
| 577 | if(defined $e->[$_IDX]){ # if $e->[$_IDX] is not defined (=> no array of child nodes, e.g.: <pb id="bka.00001-643-pb643" n="643" TEIform="pb"/>), do no recursion |
| 578 | |
| 579 | retr_info( \$e->[$_IDX] ); # recursion with array of child nodes |
| 580 | |
| 581 | $rl--; # return from recursion |
| 582 | } |
| 583 | ### |
| 584 | |
| 585 | ###### |
| 586 | # from here: closing tag-node |
| 587 | ###### |
| 588 | #print STDERR "2: dl=$dl\n" if $text_id eq "BIH_BKA.00001"; |
| 589 | # |
| 590 | { my $ix = pop @oti; |
| 591 | my $aix = @{$structures[$ix]}; |
| 592 | $fval = ${$structures[$ix]}[$aix-1]; # from-value |
| 593 | |
| 594 | # whitespace related issue |
| 595 | if( $fval>0 && not exists $hws{$fval-1} ){ |
| 596 | # previous node was a text-node |
| 597 | ${$structures[$ix]}[$aix-1] = $fval-1; # recorrect from-value |
| 598 | } |
| 599 | # |
| 600 | |
| 601 | die "ERROR ($0, retr_info()): text_id='$text_id', processing of \@structures: from-value ($fval) is more than 1 greater than to-value ($dl) => please check. aborting ...\n" if ($fval-1) > $dl; |
| 602 | ${$structures[$ix]}[$aix-1] = $dl if $fval == $dl+1; # correct from-value |
| 603 | |
| 604 | push @{$structures[$ix]}, $dl, $rl; # to-value and recursion-level |
| 605 | ### use $dl, because the offsets are _between_ the characters (e.g.: word = 'Hallo' => from = 0 (before 'H'), to = 5 (after 'o')) |
| 606 | } |
| 607 | |
| 608 | if ( $_ANNOT_GEN && $inside_annot_tag == $rl ){ |
| 609 | my $ix = pop @oti2; |
| 610 | my $aix = @{$annot[$ix]}; |
| 611 | $fval2 = ${$annot[$ix]}[$aix-1]; # from-value |
| 612 | |
| 613 | # whitespace related issue |
| 614 | if( $fval2>0 && not exists $hws{$fval2-1} ){ |
| 615 | # previous node was a text-node |
| 616 | ${$annot[$ix]}[$aix-1] = $fval2-1; # recorrect from-value |
| 617 | } |
| 618 | # |
| 619 | |
| 620 | die "ERROR ($0, retr_info()): text_id='$text_id', processing of \@annot: from-value ($fval2) is more than 1 greater than to-value ($dl) => please check. aborting ...\n" if ($fval2-1) > $dl; |
| 621 | ${$annot[$ix]}[$aix-1] = $dl if $fval2 == $dl+1; # correct from-value |
| 622 | |
| 623 | push @{$annot[$ix]}, $dl, $rl; # to-value and recursion-level |
| 624 | $inside_annot_tag = -1; # reset |
| 625 | } |
| 626 | |
| 627 | # whitespace related issue |
| 628 | # clean up |
| 629 | delete $hws{$fval-1} if $fval>0 && exists $hws{$fval-1}; |
| 630 | delete $hws{$fval2-1} if $_ANNOT_GEN && $fval2>0 && exists $hws{$fval2-1}; |
| 631 | # |
| 632 | |
| 633 | ###### |
| 634 | # from here: text nodes |
| 635 | ###### |
| 636 | }elsif( $e->[0] == XML_READER_TYPE_TEXT || $e->[0] == XML_READER_TYPE_SIGNIFICANT_WHITESPACE ){ # see 'man XML::LibXML::Reader' |
| 637 | |
| 638 | # set flag, to remember to add 1 to 'from'-$dl (see above), if this text-node was _not_ a whitespace-node |
| 639 | # NOTE: this is needed to address e.g. the following situation (see first text in goe-corpus): |
| 640 | # '... <head type="main"><s>Campagne in Frankreich</s></head><head type="sub"> <s>1792</s> ...': the from-index of the 2nd head-tag |
| 641 | # should be right before '1792' (which was produced by a text-node) and not before the ' ' (which was produced by a whitespace-node) |
| 642 | # by the way: '$add_one' is not set (resp. 're'-set) for whitespace-nodes, because they always (incidentally) set '$dl' to the right |
| 643 | # from-index of the next node (e.g.: '<w>fu</w> <w>bar</w>' or '<w>fu</w><w> </w><w>bar</w>) - this is actually not the case for |
| 644 | # text-nodes (see same previous 'fubar'-example), for which '$dl' points to the from-index of ' ', _IF_ there is alway a ' ' between |
| 645 | # two text-nodes. |
| 646 | # NOTE: A new problem arises with this approach, _IF_ there is _NOT_ a ' ' between two text-nodes |
| 647 | # (see e.g. in romanian corpus 'corola-bucurenci': ... >Anului</w><w lemma="," ana="PUNCTUATION">,</w> <w ...). |
| 648 | # In this case, the from-index for the next node would be exactly 1 to high (see in approp. zip-file for above example: |
| 649 | # '... <span id="s14" from="101" to="101" l="5"> ...' - the correct span should be: '... <span id="s14" from="100" to="101" l="5"> ...'). |
| 650 | # NOTE: it's not possible to solve the above problem here, because the following case would not be covered: |
| 651 | # ... <a><b><c><d/></c></b></a> ... (or see in goe-corpus 'GOE/AGI.04846': <div...><p/></div> ...) |
| 652 | # Because, no text- and whitespace-nodes are present, the from-values for 'a', 'b' and 'c' can only be corrected, when closing these tags. |
| 653 | # But this can be easily done by looking at the actual value of '$add_one' - if it's set, then there was no whitespace-node (and hence no ' ') |
| 654 | # before '<a>' and hence the from-values must be corrected. |
| 655 | # NOTE: To realize, what's stated in the above note, another information is needed, by which can be checked, if a tag contains text/ws or not |
| 656 | # (in the above 'abcd'-example, all tags are empty in the sense of that they don't contain any text/ws). |
| 657 | # By saving the recursion level, the 'text containing'-info can be simply checked, by the condition '$last_text_or_ws_node > $rl'. |
| 658 | # The condition is true, when there is text below the tag on level $rl. |
| 659 | ##$last_text_or_ws_node = $rl; |
| 660 | # NOTE: a much simpler solution, which should have the same effect, without following exactly the information-processing, is, to just set the |
| 661 | # value of the 'from'-index to the value of the 'to'-index, if "to==from-1" holds and to die with an error, if "(from-1)>to" holds. |
| 662 | |
| 663 | # whitespace related issue |
| 664 | if( $e->[0] == XML_READER_TYPE_SIGNIFICANT_WHITESPACE ){ |
| 665 | $add_one=0; |
| 666 | $hws{$dl}++; # '++' does not mean a thing here (could be used for consistency checking) |
| 667 | }else{ # text-node |
| 668 | $add_one=1; |
| 669 | } |
| 670 | # |
| 671 | |
| 672 | $data .= $e->[1]; |
| 673 | $dl += length($e->[1]); |
| 674 | |
| 675 | ### needed only for dummy tokenization |
| 676 | if( $_GEN_TOK_DUMMY ){ |
| 677 | $txt = $e->[1]; |
| 678 | if( (substr($txt,0,1) ne ' ' || substr($txt,1,1) ne ' ') ){ # $txt has at least 2 chars, if it is not empty or equal to ' ' |
| 679 | |
| 680 | ### start: conservative tokenization |
| 681 | # '\p{Punct}' is equal to the character class '[-!"#%&'()*,./:;?@[\\\]_{}]' |
| 682 | while( $txt =~ /([\p{Punct}]*)([^\p{Punct} \x{9}\n]+(?:([\p{Punct}]+)[^\p{Punct} \x{9}\n]+)*)?([\p{Punct}]*)(?:[ \x{9}\n])?/g ){ |
| 683 | |
| 684 | $m1=$1; $m2=$2; $m3=$3; $m4=$4; |
| 685 | |
| 686 | #print STDERR "*** m1=$1, m2="; (defined $m2)?(print STDERR "$2"):(print STDERR "undef");print STDERR ", m3="; (defined $3)?(print STDERR "$3"):(print STDERR "undef"); print STDERR ", m4=$4\n"; |
| 687 | if("$m1" ne ""){ # special chars before token |
| 688 | $p1=$-[1]; $p2=$+[1]; |
| 689 | #print STDERR "A1: ".$m1." -> from $p1 to $p2\n"; |
| 690 | if($p2==$p1+1){ |
| 691 | if($p1!=0){$tmp=substr($txt,$p1-1,1);$pr=($tmp=~/^[^A-Za-z0-9]/)}else{$pr=0}; |
| 692 | if(not $pr){$tmp=substr($txt,$p2,1);$pr=($tmp=~/^[^A-Za-z0-9]/)}; |
| 693 | if($pr){push @tok_tokens_con, $p1+$offset; push @tok_tokens_con, $p2+$offset}; # from and to |
| 694 | }else{ |
| 695 | for($i=0;$i<($p2-$p1);$i++){ |
| 696 | #print STDERR "A2: ".substr($m1,$i,1)." -> from $p1 to $p2\n"; |
| 697 | push @tok_tokens_con, $p1+$i+$offset; push @tok_tokens_con, $p1+$i+1+$offset; # from and to |
| 698 | } |
| 699 | } |
| 700 | }# "$m1" ne "" |
| 701 | #print STDERR "B: "."$m2 -> from ".($-[2]+$offset)." to ".($+[2]+$offset)."\n" if defined $m2; # token (wordform) |
| 702 | |
| 703 | if(defined $m2){push @tok_tokens_con, $-[2]+$offset; push @tok_tokens_con, $+[2]+$offset}; # from and to |
| 704 | |
| 705 | if(defined $m3){ |
| 706 | $p1=$-[3]; $p2=$+[3]; |
| 707 | #print STDERR "C: ".$m3." -> from $p1 to $p2\n"; |
| 708 | if($p2==$p1+1){ |
| 709 | $tmp=substr($txt,$p2,1);$pr=($tmp=~/^$/);$pr=($tmp=~/^[^A-Za-z0-9]/) if not $pr; # char after match |
| 710 | if(not $pr){$tmp=substr($txt,$p1-1,1);$pr=($tmp=~/^[^A-Za-z0-9]/)}; # char before match |
| 711 | if($pr){push @tok_tokens_con, $p1+$offset; push @tok_tokens_con, $p2+$offset}; # from and to |
| 712 | }else{ # length($m3)>1 => print all chars |
| 713 | for($i=0; $i<($p2-$p1); $i++){ |
| 714 | #$tmp=substr($m3,$i,1); |
| 715 | #print STDERR "C2: $tmp -> from $p1 to $p2\n"; |
| 716 | push @tok_tokens_con, $p1+$i+$offset; push @tok_tokens_con, $p1+$i+1+$offset; # from and to |
| 717 | } |
| 718 | } |
| 719 | }# defined $m3 |
| 720 | |
| 721 | if("$m4" ne ""){ # special chars after token |
| 722 | $p1=$-[4]; $p2=$+[4]; |
| 723 | #print STDERR "D1: ".$m4." -> from ".($p1+$offset)." to ".($p2+$offset)."\n"; |
| 724 | if($p2==$p1+1){ |
| 725 | $tmp=substr($txt,$p2,1);$pr=($tmp=~/^$/);$pr=($tmp=~/^[^A-Za-z0-9]/) if not $pr; # char after match |
| 726 | if(not $pr){$tmp=substr($txt,$p1-1,1);$pr=($tmp=~/^[^A-Za-z0-9]/)}; # char before match |
| 727 | if($pr){push @tok_tokens_con, $p1+$offset; push @tok_tokens_con, $p2+$offset} # from and to |
| 728 | }else{ |
| 729 | for($i=0;$i<($p2-$p1);$i++){ |
| 730 | #print STDERR "D2: ".substr($m4,$i,1)." -> from ".($p1+$i+$offset)." to ".($p1+$i+1+$offset)."\n"; |
| 731 | push @tok_tokens_con, $p1+$i+$offset; push @tok_tokens_con, $p1+$i+1+$offset; # from and to |
| 732 | } |
| 733 | } |
| 734 | }# "$m4" ne "" |
| 735 | |
| 736 | }# end: while |
| 737 | ### end: conservative tokenization |
| 738 | |
| 739 | ### start: aggressive tokenization |
| 740 | while( $txt =~ /([^\p{Punct} \x{9}\n]+)(?:([\p{Punct}])|(?:[ \x{9}\n])?)|([\p{Punct}])/g ){ |
| 741 | if(defined $1){ |
| 742 | push @tok_tokens_agg, $-[1]+$offset; push @tok_tokens_agg, $+[1]+$offset; # from and to |
| 743 | if(defined $2){push @tok_tokens_agg, $-[2]+$offset; push @tok_tokens_agg, $+[2]+$offset} # from and to |
| 744 | }else{ # defined $3 |
| 745 | push @tok_tokens_agg, $-[3]+$offset; push @tok_tokens_agg, $+[3]+$offset # from and to |
| 746 | } |
| 747 | }# end: while |
| 748 | ### end: aggressive tokenization |
| 749 | |
| 750 | #$offset = $dl+1; |
| 751 | $offset = $dl; |
| 752 | } |
| 753 | } |
| 754 | ### |
| 755 | # }#fi |
| 756 | |
| 757 | #print STDERR "1: dl=$dl\n" if $text_id eq "BIH_BKA.00001"; |
| 758 | |
| 759 | |
| 760 | # elsif( $e->[0] == XML_READER_TYPE_ATTRIBUTE ) # attribute node |
| 761 | # NOTE: attributes cannot be processed like this |
| 762 | |
| 763 | ### from here: should not really happen |
| 764 | |
| 765 | }else{ # not yet handled type |
| 766 | |
| 767 | die "ERROR ($0): Not yet handled type (\$e->[0]=".$e->[0].") ... => Aborting\n"; |
| 768 | |
| 769 | } |
| 770 | |
| 771 | }#end: foreach iteration |
| 772 | |
| 773 | }#end: sub retr_info |
| 774 | |
| 775 | |
| 776 | sub write_tok { # called from MAIN |
| 777 | |
| 778 | #print STDERR "$0: write_tok() ...\n"; |
| 779 | |
| 780 | if( $_GEN_TOK_BAS ) { |
| 781 | if( $select->can_read(3600) ){ # wait 60m for external tokenizer |
| 782 | $_ = <$chld_out>; |
| 783 | my @bounds = split; |
| 784 | write_tokenization("$_root_dir$dir/$_base_dir/$_tok_file_bas", $text_id_esc, \@bounds); |
| 785 | while($select->can_read(0)) { |
| 786 | $_ = <$chld_out>; |
| 787 | if (defined $_ && $_ ne '') { |
| 788 | print STDERR "WARNING: extra output: $_\n" |
| 789 | } else { |
| 790 | print STDERR "WARNING: tokenizer seems to have crashed, restarting.\n"; |
| 791 | startTokenizer(); |
| 792 | } |
| 793 | } |
| 794 | }else{ |
| 795 | $zip->close(); |
| 796 | die "ERROR ($0): cannot retrieve token bounds from external tokenizer for text '$text_id' => Aborting ...\n"; |
| 797 | } |
| 798 | }elsif( $_GEN_TOK_DUMMY ){ |
| 799 | write_tokenization("$_root_dir$dir/$_base_dir/$_tok_file_con", $text_id_esc, \@tok_tokens_con); |
| 800 | write_tokenization("$_root_dir$dir/$_base_dir/$_tok_file_agg", $text_id_esc, \@tok_tokens_agg); |
| 801 | } |
| 802 | #print STDERR "$0: write_tok(): DONE\n"; |
| 803 | } # end: write_tok |
| 804 | |
| 805 | sub write_tokenization { |
| 806 | my ($fname, $textid_esc, $bounds) = @_; |
| 807 | |
| 808 | $zip->newStream( Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 1, Name => $fname) |
| 809 | or die "ERROR ('$fname'): zip failed: $ZipError\n"; |
| 810 | $output = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<?xml-model href=\"span.rng\" type=\"application/xml\" schematypens=\"http://relaxng.org/ns/structure/1.0\"?>\n\n<layer docid=\"$text_id_esc\" xmlns=\"http://ids-mannheim.de/ns/KorAP\" version=\"KorAP-0.4\">\n <spanList>\n"; |
| 811 | $c=0; for( $i=0; $i < ($#$bounds + 1); $i+=2 ){ |
| 812 | $output .= " <span id=\"t_$c\" from=\"".$bounds->[$i]."\" to=\"".$bounds->[$i+1]."\" />\n"; |
| 813 | $c++; |
| 814 | } |
| 815 | $output .= " </spanList>\n</layer>"; |
| 816 | $zip->print("$output"); |
| 817 | } |
| 818 | |
| 819 | # write structure file |
| 820 | sub write_structures { # called from MAIN |
| 821 | |
| 822 | #print STDERR "$0: write_structures(): ...\n"; |
| 823 | |
| 824 | if( $dir eq "" ){ |
| 825 | print STDERR "WARNING ($0): write_structures(): empty textSigle => nothing to do ...\n"; |
| 826 | return; |
| 827 | } |
| 828 | |
| 829 | $zip->newStream( Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 1, Name => "$_root_dir$dir/$_structure_dir/$_structure_file" ) |
| 830 | or die "ERROR ('$_root_dir$dir/$_structure_dir/$_structure_file'): zip failed: $ZipError\n"; |
| 831 | |
| 832 | $output = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<?xml-model href=\"span.rng\" type=\"application/xml\" schematypens=\"http://relaxng.org/ns/structure/1.0\"?>\n\n<layer docid=\"".decode_utf8($text_id_esc)."\" xmlns=\"http://ids-mannheim.de/ns/KorAP\" version=\"KorAP-0.4\">\n <spanList>\n"; |
| 833 | |
| 834 | $c = 0; |
| 835 | |
| 836 | foreach $ref (@structures){ |
| 837 | |
| 838 | (@{$ref}==4)?($idx=1):($idx=@{$ref}-3); # if array '@{$ref}' doesn't contain attributes, then the number of elements in this array is 4 (name, from, to, rec_level), otherwise >4 |
| 839 | |
| 840 | ### correct last from-value (if the 'second to last' from-value refers to an s-tag, then the last from-value is one to big - see retr_info) |
| 841 | if( $#structures == $c && ${$ref}[$idx] == ${$ref}[$idx+1] + 1 ){ |
| 842 | ${$ref}[$idx] = ${$ref}[$idx+1]; |
| 843 | } |
| 844 | ## this consistency check is already done in 'retr_info()' |
| 845 | ##elsif( ${$ref}[$idx] > ${$ref}[$idx+1] ){ # consistency check: abort, if this doesn't hold |
| 846 | ## #die "ERROR ($0: write_structures(): \$text_id=$text_id, \$c=$c, tag-name=${$ref}[0]): 'from-index=${$ref}[$idx]' > 'to-index=${$ref}[$idx+1]' => please check! aborting ...\n"; |
| 847 | ## die "ERROR ($0: write_structures(): \$text_id=$text_id, \$c=$c, tag-name=${$ref}[0]): 'from-index=${$ref}[$idx]' > 'to-index=${$ref}[$idx+1]' => please check! aborting ...\n\n$output"; |
| 848 | ##} |
| 849 | ### |
| 850 | |
| 851 | ### at least 'POS' should always be there => remove constraint '$_ANNOT_GEN' |
| 852 | #if( $_ANNOT_GEN && ${$ref}[0] ne "$_ANNOT_TAG_NAME_RD" ){ # this is already written in 'write_annot', so don't do it twice |
| 853 | if( ${$ref}[0] ne "$_ANNOT_TAG_NAME_RD" ){ # this is already written in 'write_annot', so don't do it twice |
| 854 | |
| 855 | $output .= " <span id=\"s$c\" from=\"${$ref}[$idx]\" to=\"${$ref}[$idx+1]\" l=\"${$ref}[$idx+2]\">\n"; # l (level): insert information about depth of element in XML-tree (top element = level 1) |
| 856 | $output .= " <fs type=\"struct\" xmlns=\"http://www.tei-c.org/ns/1.0\">\n"; |
| 857 | $output .= " <f name=\"name\">${$ref}[0]</f>\n"; |
| 858 | |
| 859 | if ( $idx > 2 ) # attributes |
| 860 | { |
| 861 | $output .= " <f name=\"attr\">\n <fs type=\"attr\">\n"; |
| 862 | |
| 863 | for ( $att_idx=1; $att_idx < $idx; $att_idx+=2 ){ |
| 864 | ${$ref}[$att_idx+1] =~ s/(&|<|>)/$ent{$1}/g; # see explanation in func. 'write_annot' |
| 865 | $output .= " <f name=\"${$ref}[$att_idx]\">${$ref}[$att_idx+1]</f>\n"; # attribute (at index $att_idx) with value (at index $att_idx+1) |
| 866 | } |
| 867 | |
| 868 | $output .= " </fs>\n </f>\n"; |
| 869 | } |
| 870 | |
| 871 | $output .= " </fs>\n </span>\n"; |
| 872 | |
| 873 | } |
| 874 | |
| 875 | $c++; |
| 876 | |
| 877 | }# end: foreach |
| 878 | |
| 879 | $output .= " </spanList>\n</layer>"; |
| 880 | |
| 881 | $output=encode_utf8($output); |
| 882 | |
| 883 | $zip->print("$output"); |
| 884 | |
| 885 | #print STDERR "$0: write_structures(): DONE\n"; |
| 886 | } # end: sub write_structures |
| 887 | |
| 888 | |
| 889 | sub write_annot { # called from MAIN |
| 890 | #print STDERR "$0: write_annot(): ...\n"; |
| 891 | |
| 892 | if( $dir eq "" ){ |
| 893 | print STDERR "WARNING ($0): write_annot(): empty textSigle => nothing to do ...\n"; |
| 894 | return; |
| 895 | } |
| 896 | |
| 897 | $zip->newStream( Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD, Append => 1, Name => "$_root_dir$dir/$_ANNOT_DIR_NAME/$_ANNOT_FILE_NAME" ) |
| 898 | or die "ERROR ('$_root_dir$dir/$_ANNOT_DIR_NAME/$_ANNOT_FILE_NAME'): zip failed: $ZipError\n"; |
| 899 | |
| 900 | $output = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<?xml-model href=\"span.rng\" type=\"application/xml\" schematypens=\"http://relaxng.org/ns/structure/1.0\"?>\n\n<layer docid=\"".decode_utf8($text_id_esc)."\" xmlns=\"http://ids-mannheim.de/ns/KorAP\" version=\"KorAP-0.4\">\n <spanList>\n"; |
| 901 | |
| 902 | $c = 0; |
| 903 | |
| 904 | #open H1, ">/tmp/t456" if $text_id eq "GOE_AGA.00000"; |
| 905 | foreach $ref (@annot){ |
| 906 | |
| 907 | #if($text_id eq "GOE_AGA.00000"){ |
| 908 | #foreach my $key(@{$ref}){print H1 " $c:$key"}; |
| 909 | #print H1 "\n"; |
| 910 | #} |
| 911 | (@{$ref}==4)?($idx=1):($idx=@{$ref}-3); # if array '@{$ref}' doesn't contain attributes, then the number of elements in this array is 4 (name, from, to, rec_level), otherwise >4 |
| 912 | |
| 913 | ### correct last from-value (if the 'second to last' from-value refers to a s-tag, then the last from-value is one to big - see retr_info) |
| 914 | if( $#annot == $c && ${$ref}[$idx] == ${$ref}[$idx+1] + 1 ){ |
| 915 | ${$ref}[$idx] = ${$ref}[$idx+1]; |
| 916 | } |
| 917 | ### |
| 918 | |
| 919 | $output .= " <span id=\"s$c\" from=\"${$ref}[$idx]\" to=\"${$ref}[$idx+1]\" l=\"${$ref}[$idx+2]\">\n"; # l (level): insert information about depth of element in XML-tree (top element = level 1) |
| 920 | $output .= " <fs type=\"lex\" xmlns=\"http://www.tei-c.org/ns/1.0\">\n"; |
| 921 | ##$output .= " <f name=\"${$ref}[0]\">\n"; |
| 922 | $output .= " <f name=\"lex\">\n"; |
| 923 | |
| 924 | if ( $idx > 2 ) # attributes |
| 925 | { |
| 926 | $output .= " <fs>\n"; |
| 927 | |
| 928 | for ( $att_idx=1; $att_idx < $idx; $att_idx+=2 ){ |
| 929 | |
| 930 | ${$ref}[$att_idx+1] =~ s/(&|<|>)/$ent{$1}/g; # e.g.: look for 4th occurence of '…' in '84030_a_82705' in Drukola-Korpus 'corola-bucurenci': |
| 931 | # ... <w lemma=">" ana="PUNCTUATION">></w> ... |
| 932 | # - the '>' is translated to '>' and hence the result would be '<f name="lemma">></f>' |
| 933 | |
| 934 | if( "$_ANNOT_ATT_ANNOT_NAME_RD" && ${$ref}[$att_idx] eq "$_ANNOT_ATT_ANNOT_NAME_RD" ){ |
| 935 | |
| 936 | ${$ref}[$att_idx+1] =~ /^([^ ]+)(?: (.+))?$/; |
| 937 | die "ERROR (write_annot()): unexpected format! => Aborting ... (att: ${$ref}[$att_idx+1])\n" if ($_ANNOT_ATT_POS_NAME_WR && not defined $1) || ($_ANNOT_ATT_MSD_NAME_WR && not defined $2); |
| 938 | if( "$_ANNOT_ATT_POS_NAME_WR" ){ |
| 939 | $output .= " <f name=\"$_ANNOT_ATT_POS_NAME_WR\">"; |
| 940 | $output .= "$1" if defined $1; |
| 941 | $output .= "</f>\n"; |
| 942 | } |
| 943 | if( "$_ANNOT_ATT_MSD_NAME_WR" ){ |
| 944 | $output .= " <f name=\"$_ANNOT_ATT_MSD_NAME_WR\">"; |
| 945 | $output .= "$2" if defined $2; |
| 946 | $output .= "</f>\n"; |
| 947 | } |
| 948 | |
| 949 | }elsif( "$_ANNOT_ATT_LEM_NAME_RD" && ${$ref}[$att_idx] eq "$_ANNOT_ATT_LEM_NAME_RD" ){ |
| 950 | |
| 951 | $output .= " <f name=\"$_ANNOT_ATT_LEM_NAME_WR\">${$ref}[$att_idx+1]</f>\n"; |
| 952 | |
| 953 | }else{ # all other attributes |
| 954 | |
| 955 | $output .= " <f name=\"${$ref}[$att_idx]\">${$ref}[$att_idx+1]</f>\n"; # attribute (at index $att_idx) with value (at index $att_idx+1) |
| 956 | } |
| 957 | |
| 958 | } # end:for |
| 959 | |
| 960 | $output .= " </fs>\n"; |
| 961 | } # fi |
| 962 | |
| 963 | $output .= " </f>\n </fs>\n </span>\n"; |
| 964 | |
| 965 | $c++; |
| 966 | |
| 967 | }# end: foreach |
| 968 | #close H1 if $text_id eq "GOE_AGA.00000"; |
| 969 | |
| 970 | $output .= " </spanList>\n</layer>"; |
| 971 | |
| 972 | $output=encode_utf8($output); |
| 973 | |
| 974 | $zip->print("$output"); |
| 975 | |
| 976 | #print STDERR "$0: write_annot(): DONE\n"; |
| 977 | |
| 978 | } # end: sub write_annot |
| 979 | |
| 980 | sub printhelp { |
| 981 | print STDERR <<EOHELP; |
| 982 | This program is called from inside another script. |
| 983 | EOHELP |
| 984 | exit(); |
| 985 | } |
| 986 | |
| 987 | sub startTokenizer { |
| 988 | $pid = open2($chld_out, $chld_in, 'java -cp '. join(":", ".", glob(&dirname(__FILE__)."/../target/*.jar"))." de.ids_mannheim.korap.tokenizer.KorAPTokenizerImpl"); |
| 989 | $select = IO::Select->new(); |
| 990 | $select->add(*$chld_out); |
| 991 | } |