File Coverage

blib/lib/CAD/Firemen/ParseHelp/Wildfire5.pm
Criterion Covered Total %
statement 22 24 91.6
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 30 32 93.7


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             ######################
3             #
4             # Copyright (C) 2011 - 2015 TU Clausthal, Institut fuer Maschinenwesen, Joachim Langenbach
5             #
6             # This program is free software: you can redistribute it and/or modify
7             # it under the terms of the GNU General Public License as published by
8             # the Free Software Foundation, either version 3 of the License, or
9             # (at your option) any later version.
10             #
11             # This program is distributed in the hope that it will be useful,
12             # but WITHOUT ANY WARRANTY; without even the implied warranty of
13             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14             # GNU General Public License for more details.
15             #
16             # You should have received a copy of the GNU General Public License
17             # along with this program. If not, see .
18             #
19             ######################
20              
21             # Pod::Weaver infos
22             # PODNAME: fm_create_help
23             # ABSTRACT: Walks through an installation and tries to extract all options with informations into a database
24              
25 1     1   5 use strict;
  1         1  
  1         22  
26 1     1   5 use warnings;
  1         2  
  1         46  
27              
28             package CAD::Firemen::ParseHelp::Wildfire5;
29             {
30             $CAD::Firemen::ParseHelp::Wildfire5::VERSION = '0.7.2';
31             }
32 1     1   4 use Exporter 'import';
  1         1  
  1         40  
33             our @EXPORT_OK = qw(
34             extractHelpWildfire5
35             );
36              
37 1     1   4 use POSIX;
  1         2  
  1         5  
38 1     1   3116 use Archive::Zip qw/ :ERROR_CODES :CONSTANTS/;
  1         92594  
  1         167  
39 1     1   1090 use HTML::TreeBuilder;
  1         32149  
  1         11  
40 1     1   53601 use IO::HTML;
  1         15305  
  1         69  
41 1     1   423 use XML::LibXML;
  0            
  0            
42             use Tie::File;
43             use Term::ProgressBar;
44             use CAD::Firemen;
45             use CAD::Firemen::Common qw(
46             strip
47             testPassed
48             testFailed
49             );
50              
51             sub getChildDivs {
52             my $parent = shift;
53             my @results = ();
54              
55             if(!defined($parent) || (ref($parent) ne "HTML::Element")){
56             return @results;
57             }
58              
59             foreach my $elem ($parent->content_list()){
60             if(ref($elem) ne "HTML::Element"){
61             next;
62             }
63             if($elem->tag() eq "div"){
64             push(@results, $elem);
65             }
66             }
67             return @results;
68             }
69              
70             sub extractHelpWildfire5 {
71             my $tocUrl = shift;
72             my $language = shift;
73             my $cdbOptionsRef = shift;
74             my %cdbOptions = %{$cdbOptionsRef};
75             my $verbose = shift;
76             my $zipUrl = shift;
77              
78             # just to avoid unused warning in release tests
79             $language = undef;
80              
81             my %optionsInfo = ();
82             my %optionsValue = ();
83             my %optionsDefault = ();
84              
85             my $zip = undef;
86             if(-e $zipUrl){
87             # catch file not exists error before Zip->new(), because Zip->new() gives ugly error messages
88             $zip = Archive::Zip->new($zipUrl);
89             if(!defined($zip)){
90             testFailed("Load help archive");
91             return ({}, {}, {}, {});
92             }
93             else{
94             testPassed("Load help archive");
95             }
96             }
97              
98              
99             my @toc;
100             if(tie(@toc, 'Tie::File', $tocUrl)){
101             testPassed("Open TOC");
102             # the linebreak is needed to uncolor Term::ProgressBar
103             print "\n";
104             }
105             else{
106             testFailed("Open TOC");
107             if($verbose > 0){
108             print "TOC Url: ". $tocUrl ."\n";
109             }
110             return ({}, {}, {}, {});
111             }
112             # enabling autoflush to print parse status
113             my $lines = scalar(@toc);
114             my $progress = Term::ProgressBar->new({name => "Collecting infos", count => $lines});
115             $progress->minor(0);
116             my $i = 0;
117             my %errors = ();
118             foreach my $line (@toc){
119             my $line = strip($line);#
120             if($line =~ m/label=\"([^\"]+)\" path=\"([^(?:\"|#)]+)/){
121             my $opt = uc($1);
122             my $file = $2;
123             # exclude directories, only file paths are used here
124             if($file =~ m/\/$/){
125             next;
126             }
127             # some options exists several times, therefore only use the first entry found
128             # (Last condition)
129             if(exists($cdbOptions{$opt}) && ($file ne "") && (!exists($optionsInfo{$opt}))){
130             # option found and file path also not empty
131             my $htmlTree = HTML::TreeBuilder->new();
132             if(defined($zip)){
133             my $content = $zip->contents($file);
134             if(!$content){
135             $errors{$opt} = "Could not extract file ". $file;
136             next;
137             }
138             if(utf8::is_utf8($content)){
139             $content = utf8::decode($content);
140             }
141             $htmlTree->parse($content);
142             }
143             else{
144             next;
145             }
146              
147             # do some cleanup on the tree
148             $htmlTree->eof();
149              
150             # first check whether we've got the correct file with help of title
151             my $element = $htmlTree->find('title');
152             if(!$element){
153             $errors{$opt} = "Could not find "; </td> </tr> <tr> <td class="h" > <a name="154">154</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next; </td> </tr> <tr> <td class="h" > <a name="155">155</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="156">156</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my @contents = $element->content_refs_list(); </td> </tr> <tr> <td class="h" > <a name="157">157</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $title = uc(${$contents[0]}); </td> </tr> <tr> <td class="h" > <a name="158">158</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if($title ne $opt){ </td> </tr> <tr> <td class="h" > <a name="159">159</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $errors{$opt} = "Title are not matching (Expected: ". $opt .", Got: ". $title .")"; </td> </tr> <tr> <td class="h" > <a name="160">160</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next; </td> </tr> <tr> <td class="h" > <a name="161">161</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="162">162</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="163">163</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $element = $htmlTree->look_down("_tag", "div"); </td> </tr> <tr> <td class="h" > <a name="164">164</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my @elements = getChildDivs($element); </td> </tr> <tr> <td class="h" > <a name="165">165</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if(scalar(@elements) != 2){ </td> </tr> <tr> <td class="h" > <a name="166">166</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if(scalar(@elements) == 3){ </td> </tr> <tr> <td class="h" > <a name="167">167</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # fixing those with empty second div </td> </tr> <tr> <td class="h" > <a name="168">168</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if($elements[1]->as_trimmed_text() eq ""){ </td> </tr> <tr> <td class="h" > <a name="169">169</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $elements[1] = $elements[2]; </td> </tr> <tr> <td class="h" > <a name="170">170</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> pop(@elements); </td> </tr> <tr> <td class="h" > <a name="171">171</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="172">172</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> else{ </td> </tr> <tr> <td class="h" > <a name="173">173</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $errors{$opt} = "Second div-container of three within the first div container is not empty."; </td> </tr> <tr> <td class="h" > <a name="174">174</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next; </td> </tr> <tr> <td class="h" > <a name="175">175</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="176">176</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="177">177</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> else{ </td> </tr> <tr> <td class="h" > <a name="178">178</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $errors{$opt} = "Wrong number of div-containers within the first div container (Expected: 2, Got: ". scalar(@elements) .")"; </td> </tr> <tr> <td class="h" > <a name="179">179</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next; </td> </tr> <tr> <td class="h" > <a name="180">180</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="181">181</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="182">182</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # the first div container contains the option name and the second </td> </tr> <tr> <td class="h" > <a name="183">183</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # contains the values and the description </td> </tr> <tr> <td class="h" > <a name="184">184</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> @elements = getChildDivs($elements[1]); </td> </tr> <tr> <td class="h" > <a name="185">185</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if(scalar(@elements) < 1){ </td> </tr> <tr> <td class="h" > <a name="186">186</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $errors{$opt} = "Wrong number of div-containers within the second div container (Expected: >=1, Got: ". scalar(@elements) .")"; </td> </tr> <tr> <td class="h" > <a name="187">187</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next; </td> </tr> <tr> <td class="h" > <a name="188">188</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="189">189</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="190">190</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # get values </td> </tr> <tr> <td class="h" > <a name="191">191</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my @values = (); </td> </tr> <tr> <td class="h" > <a name="192">192</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # the text of the options div (like ansi * , iso) </td> </tr> <tr> <td class="h" > <a name="193">193</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $text = $elements[0]->as_trimmed_text(); </td> </tr> <tr> <td class="h" > <a name="194">194</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my @tmp = split(/,/, $text); </td> </tr> <tr> <td class="h" > <a name="195">195</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> foreach my $value (@tmp){ </td> </tr> <tr> <td class="h" > <a name="196">196</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # if we have replaced a *, this is the default value, </td> </tr> <tr> <td class="h" > <a name="197">197</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # because only the default value contains a star </td> </tr> <tr> <td class="h" > <a name="198">198</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if($value =~ s/\*//){ </td> </tr> <tr> <td class="h" > <a name="199">199</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $optionsDefault{$opt} = uc(strip($value)); </td> </tr> <tr> <td class="h" > <a name="200">200</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="201">201</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $value = uc(strip($value)); </td> </tr> <tr> <td class="h" > <a name="202">202</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> push(@values, $value); </td> </tr> <tr> <td class="h" > <a name="203">203</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="204">204</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $optionsValue{$opt} = [ @values ]; </td> </tr> <tr> <td class="h" > <a name="205">205</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # check extracted values against those from cdb </td> </tr> <tr> <td class="h" > <a name="206">206</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if(scalar($optionsValue{$opt}) == scalar(keys(%{$cdbOptions{$opt}}))){ </td> </tr> <tr> <td class="h" > <a name="207">207</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $errors{$opt} = "Found different values for option ". $opt ."(Expected: ". scalar(keys(%{$cdbOptions{$opt}})) .", Got: ". scalar($optionsValue{$opt}) .")"; </td> </tr> <tr> <td class="h" > <a name="208">208</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="209">209</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="210">210</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # get info (all div after the values div, contains description </td> </tr> <tr> <td class="h" > <a name="211">211</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $optionsInfo{$opt} = ""; </td> </tr> <tr> <td class="h" > <a name="212">212</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> for(my $j = 1; $j < scalar(@elements); $j++){ </td> </tr> <tr> <td class="h" > <a name="213">213</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $optionsInfo{$opt} .= $elements[$j]->as_trimmed_text() ."\n"; </td> </tr> <tr> <td class="h" > <a name="214">214</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="215">215</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # remove last linebreak </td> </tr> <tr> <td class="h" > <a name="216">216</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $optionsInfo{$opt} = strip($optionsInfo{$opt}); </td> </tr> <tr> <td class="h" > <a name="217">217</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # remove wide characters </td> </tr> <tr> <td class="h" > <a name="218">218</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $optionsInfo{$opt} =~ s/[^[:ascii:]]+//g; </td> </tr> <tr> <td class="h" > <a name="219">219</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $htmlTree->delete(); </td> </tr> <tr> <td class="h" > <a name="220">220</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="221">221</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="222">222</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $i++; </td> </tr> <tr> <td class="h" > <a name="223">223</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $progress->update($i); </td> </tr> <tr> <td class="h" > <a name="224">224</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="225">225</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if($i < $lines){ </td> </tr> <tr> <td class="h" > <a name="226">226</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $progress->update($lines); </td> </tr> <tr> <td class="h" > <a name="227">227</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="228">228</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> print "\n"; # print line break to keep the progress bar of the last step </td> </tr> <tr> <td class="h" > <a name="229">229</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> untie @toc; </td> </tr> <tr> <td class="h" > <a name="230">230</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return (\%optionsInfo, \%optionsValue, \%optionsDefault, \%errors); </td> </tr> <tr> <td class="h" > <a name="231">231</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="232">232</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="233">233</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> 1; </td> </tr> <tr> <td class="h" > <a name="234">234</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="235">235</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> __END__ </td> </tr> </table> </body> </html>