File Coverage

blib/lib/ODF/lpOD/Common.pm
Criterion Covered Total %
statement 93 367 25.3
branch 0 174 0.0
condition 0 75 0.0
subroutine 17 55 30.9
pod 11 38 28.9
total 121 709 17.0


line stmt bran cond sub pod time code
1             #=============================================================================
2             #
3             # Copyright (c) 2010 Ars Aperta, Itaapy, Pierlis, Talend.
4             # Copyright (c) 2014 Jean-Marie GouarnĂ©.
5             # Author: Jean-Marie GouarnĂ©
6             #
7             #=============================================================================
8 2     2   26 use 5.010_001;
  2         6  
  2         66  
9 2     2   9 use strict;
  2         3  
  2         62  
10 2     2   1994 use experimental 'smartmatch';
  2         1799  
  2         11  
11             #=============================================================================
12             # Common lpOD/Perl parameters and utility functions
13             #=============================================================================
14             package ODF::lpOD::Common;
15             our $VERSION = '1.013';
16 2     2   150 use constant PACKAGE_DATE => '2014-04-30T08:32:52';
  2         4  
  2         98  
17             #-----------------------------------------------------------------------------
18 2     2   10 use Scalar::Util;
  2         4  
  2         121  
19 2     2   1953 use Encode;
  2         29693  
  2         203  
20 2     2   18 use base 'Exporter';
  2         3  
  2         522  
21             our @EXPORT = qw
22             (
23             lpod_common lpod
24              
25             odf_get_document odf_new_document odf_create_document
26             odf_new_document_from_template odf_new_document_from_type
27              
28             odf_get_container odf_new_container
29             odf_new_container_from_template odf_new_container_from_type
30              
31             odf_get_xmlpart
32              
33             odf_create_element odf_create_paragraph odf_create_heading
34             odf_create_section odf_create_draw_page
35             odf_create_shape
36             odf_create_area odf_create_rectangle odf_create_ellipse
37             odf_create_vector odf_create_line odf_create_connector
38             odf_create_frame odf_create_text_frame odf_create_image_frame
39             odf_create_image
40             odf_create_list
41             odf_create_table odf_create_column odf_create_row odf_create_cell
42             odf_create_column_group odf_create_row_group
43             odf_create_field odf_create_simple_variable odf_create_user_variable
44             odf_create_note odf_create_annotation
45             odf_create_style odf_create_font_declaration
46             odf_create_toc
47              
48             odf_document odf_container
49             odf_xmlpart odf_content odf_styles odf_meta odf_settings odf_manifest
50              
51             odf_element odf_text_node
52             odf_text_element odf_text_hyperlink
53             odf_bibliography_mark odf_note odf_annotation odf_changed_region
54             odf_paragraph odf_heading odf_draw_page odf_image odf_shape odf_frame
55             odf_area odf_rectangle odf_ellipse odf_vector odf_line odf_connector
56             odf_field odf_variable odf_simple_variable odf_user_variable
57             odf_text_field odf_classify_text_field
58             odf_list odf_table odf_column odf_row odf_cell
59             odf_matrix odf_column_group odf_row_group odf_table_element
60             odf_structured_container
61             odf_section odf_toc odf_named_range
62             odf_file_entry
63              
64             odf_style
65             odf_text_style odf_paragraph_style
66             odf_list_style odf_list_level_style odf_outline_style
67             odf_table_style odf_column_style odf_row_style odf_cell_style
68             odf_data_style
69             odf_master_page odf_page_end_style odf_drawing_page_style
70             odf_page_layout odf_presentation_page_layout
71             odf_graphic_style odf_gradient
72             odf_font_declaration
73              
74             TRUE FALSE PRETTY
75             is_true is_false defined_false
76             is_odf_datatype odf_boolean process_options
77             alpha_to_num translate_coordinates translate_range
78              
79             xelt xtwig
80              
81             META CONTENT STYLES SETTINGS MANIFEST MIMETYPE
82              
83             text_segment TEXT_SEGMENT
84              
85             input_conversion output_conversion search_string count_substrings
86             color_code color_name load_color_map unload_color_map
87             is_numeric iso_date numeric_date check_odf_value odf_value
88             file_parse file_type load_file image_size input_2d_value
89             alert not_implemented
90              
91             XML_PRETTY_PRINT PRETTY_PRINT EMPTY_TAGS
92              
93             FIRST_CHILD LAST_CHILD NEXT_SIBLING PREV_SIBLING WITHIN PARENT
94             );
95              
96             #=== package name aliases ====================================================
97             #--- ODF package & parts -----------------------------------------------------
98              
99             use constant
100             {
101 2         622 odf_document => 'ODF::lpOD::Document',
102             odf_container => 'ODF::lpOD::Container',
103             odf_xmlpart => 'ODF::lpOD::XMLPart',
104             odf_content => 'ODF::lpOD::Content',
105             odf_styles => 'ODF::lpOD::Styles',
106             odf_meta => 'ODF::lpOD::Meta',
107             odf_settings => 'ODF::lpOD::Settings',
108             odf_manifest => 'ODF::lpOD::Manifest'
109 2     2   14 };
  2         4  
110              
111             #--- ODF element -------------------------------------------------------------
112              
113             use constant
114             {
115 2         1079 odf_element => 'ODF::lpOD::Element',
116             odf_text_node => 'ODF::lpOD::TextNode',
117             odf_text_element => 'ODF::lpOD::TextElement',
118             odf_text_hyperlink => 'ODF::lpOD::TextHyperlink',
119             odf_paragraph => 'ODF::lpOD::Paragraph',
120             odf_heading => 'ODF::lpOD::Heading',
121             odf_list => 'ODF::lpOD::List',
122             odf_field => 'ODF::lpOD::Field',
123             odf_variable => 'ODF::lpOD::Variable',
124             odf_simple_variable => 'ODF::lpOD::SimpleVariable',
125             odf_user_variable => 'ODF::lpOD::UserVariable',
126             odf_text_field => 'ODF::lpOD::TextField',
127             odf_table => 'ODF::lpOD::Table',
128             odf_table_element => 'ODF::lpOD::TableElement',
129             odf_matrix => 'ODF::lpOD::Matrix',
130             odf_column_group => 'ODF::lpOD::ColumnGroup',
131             odf_row_group => 'ODF::lpOD::RowGroup',
132             odf_column => 'ODF::lpOD::Column',
133             odf_row => 'ODF::lpOD::Row',
134             odf_cell => 'ODF::lpOD::Cell',
135             odf_draw_page => 'ODF::lpOD::DrawPage',
136             odf_shape => 'ODF::lpOD::Shape',
137             odf_area => 'ODF::lpOD::Area',
138             odf_rectangle => 'ODF::lpOD::Rectangle',
139             odf_ellipse => 'ODF::lpOD::Ellipse',
140             odf_vector => 'ODF::lpOD::Vector',
141             odf_line => 'ODF::lpOD::Line',
142             odf_connector => 'ODF::lpOD::Connector',
143             odf_frame => 'ODF::lpOD::Frame',
144             odf_image => 'ODF::lpOD::Image',
145             odf_section => 'ODF::lpOD::Section',
146             odf_bibliography_mark => 'ODF::lpOD::BibliographyMark',
147             odf_note => 'ODF::lpOD::Note',
148             odf_annotation => 'ODF::lpOD::Annotation',
149             odf_changed_region => 'ODF::lpOD::ChangedRegion',
150             odf_font_declaration => 'ODF::lpOD::FontDeclaration',
151             odf_style => 'ODF::lpOD::Style',
152             odf_text_style => 'ODF::lpOD::TextStyle',
153             odf_paragraph_style => 'ODF::lpOD::ParagraphStyle',
154             odf_list_style => 'ODF::lpOD::ListStyle',
155             odf_list_level_style => 'ODF::lpOD::ListLevelStyle',
156             odf_outline_style => 'ODF::lpOD::OutlineStyle',
157             odf_table_style => 'ODF::lpOD::TableStyle',
158             odf_column_style => 'ODF::lpOD::ColumnStyle',
159             odf_row_style => 'ODF::lpOD::RowStyle',
160             odf_cell_style => 'ODF::lpOD::CellStyle',
161             odf_data_style => 'ODF::lpOD::DataStyle',
162             odf_master_page => 'ODF::lpOD::MasterPage',
163             odf_page_layout => 'ODF::lpOD::PageLayout',
164             odf_presentation_page_layout => 'ODF::lpOD::PresentationPageLayout',
165             odf_graphic_style => 'ODF::lpOD::GraphicStyle',
166             odf_gradient => 'ODF::lpOD::Gradient',
167             odf_page_end_style => 'ODF::lpOD::PageEndStyle',
168             odf_drawing_page_style => 'ODF::lpOD::DrawingPageStyle',
169             odf_file_entry => 'ODF::lpOD::FileEntry',
170             odf_toc => 'ODF::lpOD::TOC',
171             odf_named_range => 'ODF::lpOD::NamedRange',
172             odf_structured_container => 'ODF::lpOD::StructuredContainer'
173 2     2   13 };
  2         3  
174              
175             #--- basic API shortcuts -----------------------------------------------------
176              
177             use constant
178             {
179 2         182 xelt => 'XML::Twig::Elt',
180             xtwig => 'XML::Twig'
181 2     2   12 };
  2         3  
182              
183             #--- lpOD common tools and parameters ----------------------------------------
184              
185             use constant
186             {
187 2         216 lpod_common => 'ODF::lpOD::Common',
188             lpod => 'ODF::lpOD::Common'
189 2     2   11 };
  2         4  
190              
191             #--- ODF data types ----------------------------------------------------------
192              
193             our @DATA_TYPES = qw(string float currency percentage date time boolean);
194              
195             #--- default string comparison function --------------------------------------
196              
197             our $COMPARE = sub { shift cmp shift };
198              
199             #=== common parameters =======================================================
200              
201             use constant # common constants
202             {
203 2         145 TRUE => 1,
204             FALSE => 0,
205 2     2   11 };
  2         2  
206              
207             use constant # ODF package parts
208             {
209 2         177 META => 'meta.xml',
210             CONTENT => 'content.xml',
211             STYLES => 'styles.xml',
212             SETTINGS => 'settings.xml',
213             MANIFEST => 'META-INF/manifest.xml',
214             MIMETYPE => 'mimetype'
215 2     2   9 };
  2         4  
216              
217             use constant
218             {
219 2         105 TEXT_SEGMENT => '#PCDATA',
220             text_segment => '#PCDATA'
221 2     2   8 };
  2         4  
222              
223             use constant # XML::Twig specific
224             {
225 2         129 EMPTY_TAGS => 'normal'
226 2     2   18 };
  2         3  
227              
228             use constant # element insert positions
229             {
230 2         1815 FIRST_CHILD => 'FIRST_CHILD',
231             LAST_CHILD => 'LAST_CHILD',
232             NEXT_SIBLING => 'NEXT_SIBLING',
233             PREV_SIBLING => 'PREV_SIBLING',
234             WITHIN => 'WITHIN',
235             PARENT => 'PARENT'
236 2     2   14 };
  2         4  
237              
238             our %ODF_TEMPLATE =
239             (
240             'text' => 'text.odt',
241             'spreadsheet' => 'spreadsheet.ods',
242             'presentation' => 'presentation.odp',
243             'drawing' => 'drawing.odg'
244             );
245              
246             our $LINE_BREAK = "\n";
247             our $TAB_STOP = "\t";
248              
249             our $INSTALLATION_PATH = undef; # lpOD library installation path
250              
251             our $LPOD_MARK = '#lpod:mark'; # lpOD session bookmark tag
252             our $LPOD_ID = '#lpod:id'; # lpOD XML ID attribute
253             our $LPOD_PART = '#lpod:part'; # lpOD link from element to xmlpart
254              
255             #=== common function aliases =================================================
256              
257             BEGIN {
258 2     2   7 *odf_get_document = *ODF::lpOD::Document::get_from_uri;
259 2         3 *odf_new_document_from_template
260             = *ODF::lpOD::Document::create_from_template;
261 2         4 *odf_new_document_from_type
262             = *ODF::lpOD::Document::_create;
263 2         4 *odf_new_document = *ODF::lpOD::Document::_create;
264 2         4 *odf_create_document = *ODF::lpOD::Document::_create;
265 2         4 *odf_get_container = *ODF::lpOD::Container::get_from_uri;
266 2         2 *odf_new_container_from_template
267             = *ODF::lpOD::Container::create_from_template;
268 2         4 *odf_new_container = *ODF::lpOD::Container::create;
269 2         4 *odf_new_container_from_type
270             = *ODF::lpOD::Container::create;
271 2         3 *odf_get_xmlpart = *ODF::lpOD::XMLPart::get;
272              
273 2         2 *odf_create_element = *ODF::lpOD::Element::_create;
274 2         10 *odf_create_paragraph = *ODF::lpOD::Paragraph::_create;
275 2         3 *odf_create_heading = *ODF::lpOD::Heading::_create;
276 2         3 *odf_create_field = *ODF::lpOD::Field::_create;
277 2         3 *odf_create_simple_variable
278             = *ODF::lpOD::SimpleVariable::_create;
279 2         5 *odf_create_user_variable
280             = *ODF::lpOD::UserVariable::_create;
281 2         3 *odf_create_table = *ODF::lpOD::Table::_create;
282 2         3 *odf_create_row_group = *ODF::lpOD::RowGroup::_create;
283 2         3 *odf_create_column_group
284             = *ODF::lpOD::ColumnGroup::_create;
285 2         4 *odf_create_column = *ODF::lpOD::Column::_create;
286 2         12 *odf_create_row = *ODF::lpOD::Row::_create;
287 2         3 *odf_create_cell = *ODF::lpOD::Cell::_create;
288 2         4 *odf_create_section = *ODF::lpOD::Section::_create;
289 2         4 *odf_create_list = *ODF::lpOD::List::_create;
290 2         2 *odf_create_draw_page = *ODF::lpOD::DrawPage::_create;
291 2         4 *odf_create_shape = *ODF::lpOD::Shape::_create;
292 2         3 *odf_create_area = *ODF::lpOD::Area::_create;
293 2         3 *odf_create_rectangle = *ODF::lpOD::Rectangle::_create;
294 2         3 *odf_create_ellipse = *ODF::lpOD::Ellipse::_create;
295 2         4 *odf_create_vector = *ODF::lpOD::Vector::_create;
296 2         3 *odf_create_line = *ODF::lpOD::Line::_create;
297 2         3 *odf_create_connector = *ODF::lpOD::Connector::_create;
298 2         3 *odf_create_frame = *ODF::lpOD::Frame::_create;
299 2         20 *odf_create_image = *ODF::lpOD::Image::_create;
300 2         4 *odf_create_text_frame = *ODF::lpOD::Frame::_create_text;
301 2         3 *odf_create_image_frame = *ODF::lpOD::Frame::_create_image;
302 2         3 *odf_create_note = *ODF::lpOD::Note::_create;
303 2         2 *odf_create_annotation = *ODF::lpOD::Annotation::_create;
304 2         4 *odf_create_font_declaration
305             = *ODF::lpOD::FontDeclaration::_create;
306 2         2 *odf_create_style = *ODF::lpOD::Style::_create;
307 2         4 *odf_classify_text_field
308             = *ODF::lpOD::TextField::classify;
309 2         3 *odf_create_toc = *ODF::lpOD::TOC::_create;
310              
311 2         10 *is_numeric = *Scalar::Util::looks_like_number;
312 2         10 *odf_value = *check_odf_value;
313              
314 2         12245 *PRETTY_PRINT = *XML_PRETTY_PRINT;
315             #initializations
316              
317             }
318              
319             #=== exported utilities ======================================================
320              
321             our $DEBUG = FALSE;
322              
323             sub alert
324             {
325 0 0   0 0   if ($DEBUG)
326             {
327 0           require Carp;
328 0           return Carp::cluck(@_);
329             }
330 0           warn "$_\n" for @_;
331             }
332              
333             sub info
334             {
335             return wantarray ?
336             (
337 0 0   0 0   name => "ODF::lpOD",
338             version => $ODF::lpOD::VERSION,
339             date => ODF::lpOD->PACKAGE_DATE,
340             path => lpod->installation_path
341             )
342             :
343             "ODF::lpOD $ODF::lpOD::VERSION" .
344             " " . ODF::lpOD->PACKAGE_DATE .
345             " " . lpod->installation_path;
346             }
347              
348 0     0 0   sub signature { scalar lpod->info }
349              
350             sub debug
351             {
352 0   0 0 0   my $param = shift // "";
353 0 0         $param = shift if $param eq lpod;
354 0           given ($param)
355             {
356 0           when (undef) {}
357 0           when (TRUE || FALSE) { $DEBUG = $_; }
  0            
358 0           default { alert "Wrong argument"; }
  0            
359             }
360 0           return $DEBUG;
361             }
362              
363             sub is_true
364             {
365 0     0 1   my $arg = shift;
366 0 0         return FALSE unless $arg;
367 0           my $v = lc $arg;
368 0 0         return $v ~~ ["false", "off", "no"] ? FALSE : TRUE;
369             }
370              
371             sub is_false
372             {
373 0 0   0 1   return is_true(shift) ? FALSE : TRUE;
374             }
375              
376             sub defined_false
377             {
378 0     0 0   my $arg = shift;
379 0 0         return FALSE unless defined $arg;
380 0 0         return is_false($arg) ? TRUE : FALSE;
381             }
382              
383             sub odf_boolean
384             {
385 0     0 1   my $value = shift;
386 0 0         return undef unless defined $value;
387 0 0         return is_true($value) ? 'true' : 'false';
388             }
389              
390             sub is_odf_datatype
391             {
392 0 0   0 1   my $type = shift or return undef;
393 0 0         return $type ~~ @DATA_TYPES ? TRUE : FALSE;
394             }
395              
396             sub check_odf_value
397             {
398 0     0 0   my $value = shift;
399 0 0         return undef unless defined $value;
400 0           my $type = shift;
401 0           given ($type)
402             {
403             when (['float', 'currency', 'percentage'])
404 0           {
405 0 0         $value = undef unless is_numeric($value);
406             }
407             when ('boolean')
408 0           {
409 0 0         if (is_true($value))
410             {
411 0           $value = 'true';
412             }
413             else
414             {
415 0           $value = 'false';
416             }
417             }
418             when ('date')
419 0           {
420 0 0         if (is_numeric($value))
421             {
422 0           $value = iso_date($value);
423             }
424             else
425             {
426 0           my $num = numeric_date($value);
427 0 0         $value = defined $num ?
428             iso_date($num) : undef;
429             }
430             }
431             }
432 0           return $value;
433             }
434              
435             sub process_options
436             {
437 0     0 0   my %in = (@_);
438 0           my %out = ();
439 0           foreach my $ink (keys %in)
440             {
441 0           my $outk = $ink;
442 0           $outk =~ s/[ -]/_/g;
443 0           $out{$outk} = $in{$ink};
444             }
445 0           return %out;
446             }
447              
448             sub alpha_to_num
449             {
450 0 0   0 0   my $arg = shift or return 0;
451 0 0 0       $arg = shift if ref($arg) || $arg eq __PACKAGE__;
452 0           my $alpha = uc $arg;
453 0 0         unless ($alpha =~ /^[A-Z]*$/)
454             {
455 0 0         return $arg if $alpha =~ /^[0-9\-]*$/;
456 0           alert "Wrong alpha value $arg";
457 0           return undef;
458             }
459 0           my @asplit = split('', $alpha);
460 0           my $num = 0;
461 0           foreach my $p (@asplit)
462             {
463 0           $num *= 26;
464 0           $num += ((ord($p) - ord('A')) + 1);
465             }
466 0           $num--;
467 0           return $num;
468             }
469              
470             sub translate_coordinates # adapted from OpenOffice::OODoc (Genicorp)
471             {
472 0   0 0 1   my $arg = shift // return undef;
473 0           my $ra = ref $arg;
474 0 0         if ($ra)
    0          
475             {
476 0 0         if ($ra eq 'ARRAY') { return @$arg }
  0            
477 0           else { shift }
478             }
479             elsif ($arg eq __PACKAGE__)
480             {
481             shift
482 0           }
483 0 0         return ($arg, @_) unless defined $arg;
484 0           my $coord = uc $arg;
485 0 0         return ($arg, @_) unless $coord =~ /[A-Z]/;
486              
487 0           $coord =~ s/\s*//g;
488 0           $coord =~ /(^[A-Z]*)(\d*)/;
489 0           my $c = $1;
490 0           my $r = $2;
491 0 0         return ($arg, @_) unless $c;
492 0           my $colnum = alpha_to_num($c);
493 0 0 0       if (defined $r and $r gt "")
494             {
495 0           $r--;
496 0           return ($r, $colnum, @_);
497             }
498             else
499             {
500 0           return ($colnum, @_);
501             }
502             }
503              
504             sub translate_range
505             {
506 0   0 0 1   my $arg = shift // return undef;
507 0 0 0       $arg = shift if ref($arg) || $arg eq __PACKAGE__;
508 0 0 0       return ($arg, @_) unless (defined $arg && $arg =~ /:/);
509 0           my $range = uc $arg;
510 0           $range =~ s/\s*//g;
511 0           my ($start, $end) = split(':', $range);
512 0           my @r = ();
513 0           push @r, translate_coordinates($_) for ($start, $end);
514 0           return @r;
515             }
516              
517             #--- external character set conversion utilities -----------------------------
518              
519             our $INPUT_CHARSET = 'utf8';
520             our $OUTPUT_CHARSET = 'utf8';
521             our $INPUT_ENCODER = Encode::find_encoding($INPUT_CHARSET);
522             our $OUTPUT_ENCODER = Encode::find_encoding($OUTPUT_CHARSET);
523              
524 0     0 0   sub get_input_charset { $INPUT_CHARSET }
525              
526 0     0 0   sub get_output_charset { $OUTPUT_CHARSET }
527              
528             sub set_input_charset
529             {
530 0   0 0 0   my $charset = shift // "";
531 0 0         $charset = shift if ($charset eq lpod);
532 0           my $enc = Encode::find_encoding($charset);
533 0 0         unless ($enc)
534             {
535 0           alert("Unsupported $charset input character set");
536 0           return FALSE;
537             }
538 0           $INPUT_ENCODER = $enc;
539 0           $INPUT_CHARSET = $charset;
540 0           return $INPUT_CHARSET;
541             }
542              
543             sub set_output_charset
544             {
545 0   0 0 0   my $charset = shift // "";
546 0 0         $charset = shift if ($charset eq lpod);
547 0           my $enc = Encode::find_encoding($charset);
548 0 0         unless ($enc)
549             {
550 0           alert("Unsupported output character set");
551 0           return FALSE;
552             }
553 0           $OUTPUT_ENCODER = $enc;
554 0           $OUTPUT_CHARSET = $charset;
555 0           return $OUTPUT_CHARSET;
556             }
557              
558             sub input_conversion
559             {
560 0     0 0   my $text = shift;
561 0 0         return $text unless $INPUT_CHARSET;
562              
563 0 0         unless ($INPUT_ENCODER)
564             {
565 0           alert "Unsupported input character conversion";
566 0           return $text;
567             }
568 0 0         return (defined $text) ? $INPUT_ENCODER->decode($text) : undef;
569             }
570              
571             sub output_conversion
572             {
573 0     0 0   my $text = shift;
574 0 0         return $text unless $OUTPUT_CHARSET;
575              
576 0 0         unless ($OUTPUT_ENCODER)
577             {
578 0           alert "Unsupported output character conversion";
579 0           return $text;
580             }
581              
582 0 0         return (defined $text) ? $OUTPUT_ENCODER->encode($text) : undef;
583             }
584              
585             #--- ISO-9601 / internal date conversion -------------------------------------
586              
587             sub iso_date
588             {
589 0   0 0 1   my $time = shift // time();
590 0           my @t = localtime($time);
591 0           return sprintf
592             (
593             "%04d-%02d-%02dT%02d:%02d:%02d",
594             $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]
595             );
596             }
597              
598             sub numeric_date # in progress
599             {
600 0     0 1   require Time::Local;
601              
602 0 0         my $iso_date = shift or return undef;
603 0 0         $iso_date .= 'T00:00:00'unless ($iso_date =~ /T/);
604 0           $iso_date =~ /(\d*)-(\d*)-(\d*)T(\d*):(\d*):(\d*)/;
605 0   0       my $sec = $6 || 0; my $min = $5 || 0; my $hrs = $4 || 0;
  0   0        
  0   0        
606 0   0       my $day = $3 || 1; my $mon = $2 || 1; my $year = $1 || 0;
  0   0        
  0   0        
607 0           return Time::Local::timelocal($sec,$min,$hrs,$day,$mon-1,$year);
608             }
609              
610             #-----------------------------------------------------------------------------
611              
612             sub count_substrings
613             {
614 0     0 0   my $content = shift;
615 0           my $expr = shift;
616 0 0         return undef unless defined $expr;
617 0           my @matches = ($content =~ /$expr/g);
618 0           return scalar @matches;
619             }
620              
621             sub search_string
622             {
623 0     0 0   my $content = shift;
624 0           my $expr = shift;
625 0 0         return undef unless defined $expr;
626 0           my %opt =
627             (
628             replace => undef,
629             offset => undef,
630             range => undef,
631             @_
632             );
633 0           my $start = $opt{offset};
634 0           my $ln = length($content);
635 0 0 0       if ((defined $start) and (abs($start) >= $ln))
636             {
637 0           alert "[$start $ln] out of range";
638 0           return undef;
639             }
640 0           my $range = $opt{range};
641 0 0         if (defined $start)
642             {
643 0 0         $start = $start + $ln if $start < 0;
644 0 0         $content = defined $range ?
645             substr($content, $start, $range) :
646             substr($content, $start);
647             }
648 0 0         unless (defined $opt{replace})
649             {
650 0 0         if ($content =~ /$expr/)
651             {
652 0           my $start_pos = length($`);
653 0 0         $start_pos += $start if defined $start;
654 0           my $end_pos = $start_pos + length($&);
655 0           my $match = $&;
656             return wantarray ?
657 0 0         ($start_pos, $end_pos, $match) :
658             $start_pos;
659             }
660             else
661             {
662 0 0         return wantarray ? (undef) : undef;
663             }
664             }
665             else
666             {
667 0           my $rep = $opt{replace};
668 0           my $count = ($content =~ s/$expr/$rep/g);
669 0 0         if (wantarray)
670             {
671 0           return ($content, $count);
672             }
673             else
674             {
675 0 0         return $count ? $content : undef;
676             }
677             }
678             }
679              
680             #-----------------------------------------------------------------------------
681              
682             sub file_type
683             {
684 0     0 1   require File::Type;
685 0           my $f = shift;
686 0 0 0       return undef unless (-r $f && -f $f);
687 0           return File::Type->new->mime_type($f);
688             }
689              
690             sub file_parse
691             {
692 0     0 1   require File::Basename;
693 0           my $source = shift;
694 0 0         if (wantarray)
695             {
696 0           my ($name,$path,$suffix) =
697             File::Basename::fileparse($source, qr/\.[^.]*/);
698 0 0         if (defined $suffix)
699             {
700 0           $name .= $suffix;
701 0           $suffix =~ s/^\.//;
702             }
703 0           return ($name, $path, $suffix);
704             }
705 0           return File::Basename::fileparse($source);
706             }
707              
708             sub load_file
709             {
710 0 0   0 0   my $url = shift or return undef;
711 0   0       my $mode = shift // ':utf8';
712              
713 0 0 0       if (! ref $url and $url =~ /:/ and uc($url) !~ /^[A-Z]:/)
      0        
714             {
715 0           require LWP::Simple;
716 0           $url =~ s{\\}{/};
717 0           return LWP::Simple::get($url);
718             }
719             else
720             {
721 0 0 0       return undef unless ref $url or -r -f -e $url;
722 0           require File::Slurp;
723 0           return scalar File::Slurp::read_file
724             ($url, binmode => $mode);
725             }
726             }
727              
728             sub image_size
729             {
730 0 0   0 1   my $url = shift or return undef;
731 0           my %opt = @_;
732 0           my $source;
733              
734 0 0         if (ref $url eq 'SCALAR')
    0          
735             {
736 0           $source = $url;
737             }
738             elsif ($opt{document})
739             {
740 0           $source = \($opt{document}->get_part($url));
741             }
742             else
743             {
744 0           $source = \(load_file($url, ':raw'));
745             }
746              
747 0 0         if ($source)
748             {
749 0           require Image::Size;
750 0           my ($w, $h) = Image::Size::imgsize($source);
751 0 0         return undef unless defined $w;
752 0 0         if (wantarray)
753             {
754 0           return ($w, $h);
755             }
756             else
757             {
758 0           $w .= 'pt'; $h .= 'pt';
  0            
759 0           return [$w, $h];
760             }
761             }
762             else
763             {
764 0           return undef;
765             }
766             }
767              
768             sub input_2d_value
769             {
770 0 0   0 0   my $arg = shift or return undef;
771 0   0       my $u = shift // 'cm';
772 0           my ($x, $y);
773 0 0         if (ref $arg)
    0          
774             {
775 0           $x = $arg->[0]; $y = $arg->[1];
  0            
776             }
777             elsif ($arg)
778             {
779 0 0         if ($arg =~ /,/)
780             {
781 0           $arg =~ s/\s*//g;
782 0           ($x, $y) = split(',', $arg);
783             }
784             else
785             {
786 0           $x = $arg; $y = shift;
  0            
787             }
788             }
789 0   0       $x ||= ('0' . $u); $y ||= ('0' . $u);
  0   0        
790 0 0         $x .= $u unless $x =~ /[a-zA-Z]$/;
791 0 0         $y .= $u unless $y =~ /[a-zA-Z]$/;
792 0 0         return wantarray ? ($x, $y) : [$x, $y];
793             }
794              
795             #--- symbolic color names handling -------------------------------------------
796              
797             our %COLORCODE = ();
798             our %COLORNAME = ();
799              
800             sub color_code
801             {
802 0 0   0 0   my $name = shift or return undef;
803 0 0 0       if ($name && ($name =~ /^#/)) { return $name }
  0            
804 0           return $COLORCODE{$name};
805             }
806              
807             sub color_name
808             {
809 0 0   0 0   my $code = shift or return undef;
810 0           return $COLORNAME{lc $code};
811             }
812              
813             sub load_color_map
814             {
815 0   0 0 0   my $filename = shift || (installation_path() . '/data/rgb.txt');
816 0 0 0       unless ( -e $filename && -r $filename )
817             {
818 0 0         warn "Color map file non existent or unreadable"
819             if $DEBUG;
820 0           return FALSE;
821             }
822 0           my $r = open COLORS, "<", $filename;
823 0 0         unless ($r)
824             {
825 0           alert "Error opening $filename"; return FALSE;
  0            
826             }
827 0           while (my $line = )
828             {
829 0           $line =~ s/^\s*//; $line =~ s/\s*$//;
  0            
830 0 0         next unless $line =~ /^[0-9]/;
831 0           $line =~ /(\d*)\s*(\d*)\s*(\d*)\s*(.*)/;
832 0           my $name = $4;
833 0 0         $COLORCODE{$name} = sprintf("#%02x%02x%02x", $1, $2, $3)
834             if $name;
835             }
836 0           close COLORS;
837 0           %COLORNAME = reverse %COLORCODE;
838 0           return TRUE;
839             }
840              
841             sub unload_color_map
842             {
843 0     0 0   my $self = shift;
844 0           %COLORCODE = ();
845 0           %COLORNAME = ();
846 0           return TRUE;
847             }
848              
849             #-----------------------------------------------------------------------------
850              
851 0     0 0   sub installation_path { $INSTALLATION_PATH }
852              
853             sub template
854             {
855 0   0 0 0   my $type = shift // "";
856 0 0         $type = shift if $type eq lpod;
857              
858 0           my $filename = $ODF_TEMPLATE{$type};
859 0 0         unless ($filename)
860             {
861 0           alert("Unsupported type");
862 0           return FALSE;
863             }
864 0           my $fullpath = installation_path() . '/templates/' . $filename;
865 0 0         unless (-r -f -e $fullpath)
866             {
867 0           alert("Template not available");
868 0           return FALSE;
869             }
870 0           return $fullpath;
871             }
872              
873             #--- session ID generator ----------------------------------------------------
874              
875             our $LPOD_ID_PATTERN = 'lpOD_%09x';
876             sub new_id
877             {
878 0     0 0   state $count = 0;
879 0           return sprintf($LPOD_ID_PATTERN, ++$count);
880             }
881              
882             #--- pretty XML output option ------------------------------------------------
883              
884             our $XML_PRETTY_PRINT_MODE = 'indented';
885              
886             sub XML_PRETTY_PRINT
887             {
888 0   0 0 0   my $pp = shift // "";
889 0 0         $pp = shift if ($pp eq lpod);
890 0 0         $XML_PRETTY_PRINT_MODE = $pp if $pp;
891 0           return $XML_PRETTY_PRINT_MODE;
892             }
893              
894             #-----------------------------------------------------------------------------
895              
896             sub not_implemented
897             {
898 0     0 0   alert("NOT IMPLEMENTED");
899 0           return FALSE;
900             }
901              
902             #=============================================================================
903             1;