File Coverage

blib/lib/Filter/Heredoc/App.pm
Criterion Covered Total %
statement 30 313 9.5
branch 0 162 0.0
condition 0 66 0.0
subroutine 10 25 40.0
pod 1 1 100.0
total 41 567 7.2


line stmt bran cond sub pod time code
1             package Filter::Heredoc::App;
2              
3 1     1   10399 use 5.010;
  1         4  
  1         46  
4 1     1   7 use strict;
  1         2  
  1         312  
5 1     1   6 use warnings;
  1         3  
  1         58  
6              
7             our $VERSION = '0.02';
8              
9             =head1 NAME
10              
11             Filter::Heredoc::App - The module behind the filter-heredoc command
12              
13             =head1 VERSION
14              
15             Version 0.02
16              
17             =cut
18              
19 1     1   5 use base qw( Exporter );
  1         2  
  1         120  
20             our @EXPORT_OK = qw ( run_filter_heredoc );
21              
22 1     1   5 use Filter::Heredoc qw( hd_getstate hd_init hd_labels );
  1         1  
  1         94  
23 1     1   6 use Filter::Heredoc::Rule qw( hd_syntax );
  1         2  
  1         46  
24 1     1   5 use File::Basename qw( basename );
  1         2  
  1         90  
25 1     1   9981 use POSIX qw( strftime );
  1         24842  
  1         9  
26 1     1   2785 use Getopt::Long;
  1         16139  
  1         8  
27 1     1   198 use Carp;
  1         2  
  1         4715  
28              
29             our $SCRIPT = basename($0);
30              
31             our @gl_delimiterarray = (); # delimiters to match
32             our @gl_to_be_unique_delimiters = (); # (to be) unique delimiters
33             our $gl_is_successful_match = 0; # successful match flag
34              
35             ### Export_ok subroutines starts here ###
36              
37             ### INTERFACE SUBROUTINE ###
38             # Usage : run_filter_heredoc()
39             # Purpose : This module implements the logic and functions to
40             # search and filter here documents in scripts.
41             # This is the code behind the filter-heredoc command.
42             # Return : Normally returns to caller or dies with exit code 0.
43             # Errors : Dies with exit code 1 on user errors. Dies with exit
44             # code 2 on internal errors in hd_getstate().
45             # Throws : No.
46              
47             sub run_filter_heredoc {
48              
49 0     0 1   my $linestate;
50             my %state;
51 0           my $EMPTY_STR = q{};
52 0           my $PROMPT = q{> };
53 0           my $POD = q{pod};
54 0   0       my $is_interactive = ( ( -t STDIN ) && ( -t STDOUT ) );
55 0           my $is_use_prompt = $EMPTY_STR;
56 0           my $is_with_fileinfo = $EMPTY_STR;
57              
58 0           my %user_warning = (
59             firstexclusive =>
60             q{Options --help(-h), --version(-v) or --rules(-r) can't be specfied at the same time.},
61             exclusive =>
62             q{Options --list(-l), --list-unique(-u), --debug(-d) or '-' can't be specfied at the same time.},
63             delimiters =>
64             q{Options --list(-l), --list-unique(-u) or --match(-m) can't be specfied at the same time.},
65             filename =>
66             q{Missing any file arguments. Type --help for information.},
67             notextfile =>
68             q{Please try again, and limit the files to readable text files.},
69             );
70              
71             # Flush all state arays and activate syntax rule 'pod' as default
72 0           hd_init();
73 0           hd_syntax($POD);
74              
75             # Configure long options handling
76 0           Getopt::Long::Configure("no_auto_abbrev")
77             ; # must spell out full long option
78 0           Getopt::Long::Configure("bundling"); # bundle the short options
79 0           Getopt::Long::Configure("no_ignore_case"); # use correct case
80              
81             ##############################################################
82             # Do some internal checks before @ARGV is shifted by Getopt
83             ##############################################################
84              
85             # Have we the mandatory filename argument on the command line. In
86             # a pipe or redirect, @ARGV is empty, therefore '$is_interactive'.
87 0 0 0       if ( ($is_interactive) && ( $#ARGV == -1 ) ) {
88 0           _print_to_stderr_exit( \$user_warning{filename} );
89             }
90              
91             # Test and prepare possible for line-by-line interactive mode.
92 0           $is_use_prompt = _is_lone_cli_dash(@ARGV);
93              
94             ##############################################################
95             # Getopt to decode our command line arguments
96             ##############################################################
97              
98 0           my ($is_help, $is_version, $is_quiet, $is_rules,
99             $is_debug, $is_list, $is_unique
100             ) = ( 0, 0, 0, 0, 0, 0, 0 );
101 0           my ( $syntax, $match ) = ( $EMPTY_STR, $EMPTY_STR );
102              
103 0           my $options_okay = GetOptions(
104             "h|help" => \$is_help,
105             "v|version" => \$is_version,
106             "q|quiet" => \$is_quiet,
107             "d|debug" => \$is_debug,
108             "i|interactive" => \$is_use_prompt,
109             "r|rules" => \$is_rules,
110             "l|list" => \$is_list,
111             "u|list-unique" => \$is_unique,
112             "s|syntax=s" => \$syntax,
113             "m|match=s" => \$match,
114             );
115              
116             ##############################################################
117             # Getopt done.
118             ##############################################################
119              
120 0 0         _help() if !$options_okay;
121              
122             ########################################
123             # Exclusive do-and-exit-options: --version, --help, and --rules
124 0           my $useroptions = 0;
125 0           foreach ( $is_help, $is_version, $is_rules ) {
126 0 0         $useroptions++ if $_;
127             }
128 0 0         _print_to_stderr_exit( \$user_warning{firstexclusive} )
129             if ( $useroptions > 1 );
130              
131             ########################################
132             # Execute the do-and-exit options first
133 0 0         if ($is_help) {
    0          
    0          
134 0           _print_help();
135             }
136             elsif ($is_version) {
137 0           _print_version();
138             }
139             elsif ($is_rules) {
140 0           _print_rules();
141             }
142              
143             ########################################
144             # Populate the global array of target delimiters to match
145 0 0         if ($match) {
146 0           _set_match_delimiters($match);
147             }
148             ########################################
149             # Exclusive options tests
150             # Test --list, --list-unique, --debug and '-'
151 0           $useroptions = 0;
152 0           foreach ( $is_list, $is_debug, $is_use_prompt, $is_unique ) {
153 0 0         $useroptions++ if $_;
154             }
155 0 0         _print_to_stderr_exit( \$user_warning{exclusive} ) if ( $useroptions > 1 );
156              
157             # --list or --list-unique (prints all delimiters)
158             # and --match (use specific delimiter) is mutually exclusive.
159 0 0 0       if ( $is_list || $is_unique ) {
160              
161             # Array contains elements, e.g. '--match=eof,eot' is given
162 0 0 0       if ( ( $#gl_delimiterarray >= 0 ) && ($match) ) {
163 0           _print_to_stderr_exit( \$user_warning{delimiters} );
164             }
165             }
166              
167             # Should we switch to interactive mode (here line-by-line input)
168 0 0         if ($is_use_prompt) {
169 0 0         if ( !$is_interactive ) {
170 0           _help();
171             }
172             else {
173 0           print "$SCRIPT: Line by line input - use Ctrl-D to quit\n";
174 0           print $PROMPT;
175             }
176             }
177              
178             # Again! Test that we have the mandatory filename arguments
179             # Getopt have mangled the @ARGV content after removing options.
180 0 0         if ( !$is_use_prompt ) {
181 0 0 0       _print_to_stderr_exit( \$user_warning{filename} )
182             if ( $is_interactive && ( $#ARGV == -1 ) );
183             }
184              
185             ###########################################################
186             # Before we let <> loose, sanitize the file list in @ARGV.
187             # Only allow text files, and exit if not.
188             ###########################################################
189              
190             # Shell have already expanded '*' in @ARGV to file list
191 0           my @files = @ARGV;
192 0           my @text_files = ();
193              
194 0 0 0       if ( ( $#files != -1 ) && ( !_is_lone_cli_dash(@ARGV) ) ) {
195 0           my @no_good_files;
196 0           my $exit_now_flag = 0;
197              
198 0           foreach ( 0 .. $#files ) {
199              
200 0 0         if ( !-e $files[$_] ) {
201 0           print STDERR
202             "$SCRIPT: cannot access '$files[$_]': Can not access file. Does it exist?\n";
203 0           exit(1);
204             }
205              
206             # exclude directories
207 0 0         if ( -d $files[$_] ) {
    0          
208 0           next;
209             }
210              
211             # readable by effective user id, plain file, and text
212             elsif ( -r -f -T $files[$_] ) {
213 0           push @text_files, $files[$_];
214             }
215             else {
216 0           $exit_now_flag = 1;
217 0           push @no_good_files, $files[$_];
218             }
219              
220             }
221 0 0         if ($exit_now_flag) {
222              
223 0 0         if (@text_files) {
224 0           print STDERR "$SCRIPT: These may be acceptable text files:\n";
225 0           foreach my $item (@text_files) {
226 0           print STDERR "'$item', ";
227             }
228 0           print STDERR "\n";
229             }
230 0           print STDERR
231             "$SCRIPT: These are not plain text files or are not accessible (maybe links):\n";
232 0           foreach my $item (@no_good_files) {
233 0           print STDERR "'$item', ";
234             }
235 0           print STDERR "\n$SCRIPT: ";
236 0           my $allstderrprintdone = 1;
237              
238 0 0         _print_to_stderr_exit( \$user_warning{notextfile} )
239             if ($allstderrprintdone);
240              
241             } # end exit_now_flag_flag
242             }
243              
244             # Last time test that we have the mandatory filename arguments after
245             # that we mangled the file list @text_files content.
246 0 0         if ( !$is_use_prompt ) {
247 0 0 0       _print_to_stderr_exit( \$user_warning{filename} )
248             if ( $is_interactive && ( $#text_files == -1 ) );
249             }
250              
251             ###########################################################
252             # Set our syntax if given any
253 0 0         if ($syntax) {
254 0           _set_syntax_rules($syntax);
255             }
256              
257             ###########################################################
258             # Main loop processing one line after line from STDIN
259             ###########################################################
260 0           while ( defined( my $line = ) ) {
261              
262             # print all here-doc delimiters (i.e. '--list' or '--list-unique')
263 0 0 0       if ( ( $is_list || $is_unique ) && ( !$is_use_prompt ) ) {
    0 0        
264              
265 0 0         if ( !$is_quiet ) {
266 0           $is_with_fileinfo = 1; # adds file information
267             }
268 0           _print_all_delimiters( $line, $is_with_fileinfo, $is_unique );
269              
270             }
271              
272             # end --list, --list-unique options (print all here-doc delimiters)
273              
274             elsif ( !$is_use_prompt ) {
275              
276             ### print here-doc content (default without any options)
277 0           my $is_add_label;
278 0 0         if ( !$is_quiet ) {
279 0           $is_with_fileinfo = 1; # file information when printing
280             }
281              
282             # print all lines for debug incl state code (i.e. --debug option)
283 0 0         if ($is_debug) {
284 0           $is_add_label = 1;
285 0           _debug_every_line( $line, $is_with_fileinfo, $is_add_label );
286             }
287              
288             # print only the embedded here document lines (default option)
289             else {
290 0           $is_add_label = $EMPTY_STR;
291 0           _print_heredoc( $line, $is_with_fileinfo, $is_add_label );
292             }
293             ### end print here-doc content
294              
295             }
296              
297             # Inter-active and no cmd line arguments.
298 0 0         if ($is_use_prompt) {
    0          
299              
300             ############## If exception exit(2) ########
301 0           eval { %state = hd_getstate($line); };
  0            
302 0 0         if ($@) {
303 0           my $logcreated = _write_error_file( $@, _get_error_fname() );
304 0 0         if ($logcreated) {
305 0           print STDERR "Fatal internal errors, see file:",
306             _get_error_fname(), "\n";
307             }
308 0           exit(2);
309             }
310             ############################################
311 0           print "$state{statemarker}]$line";
312              
313 0           print $PROMPT; # We can test the script with Test::Expect
314             }
315             elsif (eof) {
316              
317             # --list-unique
318 0 0         if ($is_unique) {
319 0 0         if ($is_quiet) {
320 0           _print_unique_delimiters($EMPTY_STR);
321             }
322             else {
323 0           _print_unique_delimiters($ARGV); # current file name
324             }
325 0           print "\n"; # new line after each file
326             }
327              
328             # --match
329 0 0         if ($match) {
330 0 0         if ( !$gl_is_successful_match ) {
331 0 0         print "($ARGV)" unless ($is_quiet);
332 0           print
333             "Sorry, no here document content matched your delimiter(s): '$match'. Try --list.\n";
334             }
335              
336 0           $gl_is_successful_match = $EMPTY_STR; # False
337             }
338              
339              
340 0           close(ARGV);
341 0           hd_init()
342             ; # re-init state explicitely to flush state possible errors
343             }
344              
345             # end inter-active and no cmd line arguments
346              
347             }
348              
349 0           print "\n"; # print one LF before returning to caller script and exit.
350 0           return;
351              
352             }
353              
354             ### The Module private subroutines starts here ###
355              
356             ### INTERNAL UTILITY ###
357             # Usage : _print_help()
358             # Purpose : Print command line help
359             # Returns : No, dies with exit code 0
360             # Throws : No
361              
362             sub _print_help {
363              
364 0     0     print <<"END_USAGE";
365            
366             $SCRIPT: Filter embedded here-documents in scripts
367            
368             Usage:
369              
370             $SCRIPT [options] file
371             $SCRIPT [options] < file
372             cat file | $SCRIPT [options] | program
373              
374             file: Source script file with embedded here-documents
375             program: Program to receive input from $SCRIPT output
376              
377             Options
378              
379             --list,-l : list all delimiters and exit.
380             --list-unique,-u : list only unique delimiters and exit.
381             --match=,-m : print only here-documents matching the delimiters.
382             --quiet,-q : supress file information.
383              
384             --rules,-r : list available rules and exit.
385             --syntax=,-s : add specified rule(s).
386            
387             --help,-h : show this help and exit.
388             --version,-v : print $SCRIPT version information and exit.
389             --debug,-d : print all script lines, not only here-document lines.
390             --interactive,-i|- : enter text line-by-line (for state debugging).
391            
392             Type 'perldoc $SCRIPT' for more information.
393            
394             END_USAGE
395              
396 0           exit(0);
397              
398             }
399              
400             ### INTERNAL UTILITY ###
401             # Usage : _print_version()
402             # Purpose : Print version, copyright and disclaimer
403             # Returns : No, dies with exit code 0
404             # Throws : No
405              
406             sub _print_version {
407              
408 0     0     print <<"END_VERSION";
409            
410             $SCRIPT, version $VERSION
411             Copyright 2011, Bertil Kronlund
412            
413             This program is free software; you can redistribute it and/or modify it
414             under the terms of either: the GNU General Public License as published
415             by the Free Software Foundation; or the Artistic License.
416              
417             See http://dev.perl.org/licenses/ for more information.
418            
419             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
420             IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
421             WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
422              
423             END_VERSION
424              
425 0           exit(0);
426              
427             }
428              
429             ### INTERNAL UTILITY ###
430             # Usage : _print_rules()
431             # Purpose : print the available syntax rules
432             # Returns : No, dies with exit code 0
433             # Throws : No
434              
435             sub _print_rules {
436 0     0     my $EMPTY_STR = q{};
437 0           my $value = shift;
438 0           my %syntax;
439              
440 0 0         if ( !defined $value ) {
441              
442             # Request rule capabilities
443 0           %syntax = hd_syntax();
444              
445 0           print "Available options to use with --syntax option: ";
446 0           foreach ( keys %syntax ) {
447 0           print "'$_' ";
448 0 0         if ( $syntax{$_} ne $EMPTY_STR ) {
449 0           print '(active) ';
450             }
451             }
452              
453 0           print "\n";
454 0           exit(0);
455             }
456              
457             }
458              
459             ### INTERNAL UTILITY ###
460             # Usage : _set_syntax_rules()
461             # Purpose : Sets the syntax rule during this run.
462             # Returns : Normally returns to caller or dies
463             # with exit code 1 on user error.
464             # Throws : No
465              
466             sub _set_syntax_rules {
467 0     0     my $EMPTY_STR = q{};
468 0           my $NONE = q{none};
469 0           my $rule = shift;
470 0           my %syntax;
471              
472 0 0         if ( $rule =~ m/^-/xsm ) {
473 0           print "Invalid --syntax argument option: '$rule'\n";
474 0           exit(1);
475             }
476             else {
477              
478             # Try to set given rule
479 0           $rule = lc($rule); # Ignore case
480 0           %syntax = hd_syntax($rule);
481              
482             # if rule is word 'none' (i.e flush all rules) we are done
483 0 0         if ( $rule ne $NONE ) {
484              
485             # Was this a non-existent key?
486 0 0         if ( !exists $syntax{$rule} ) {
    0          
487 0           print "Invalid syntax rule option: '$rule'. ",
488             "Try option --rules to view all available.\n";
489 0           exit(1);
490             }
491              
492             # Was the change applied
493             elsif ( $syntax{$rule} eq $EMPTY_STR ) {
494 0           print "Sorry, could not add new rule: '$rule'. ",
495             "Try option --rules to view all available.\n";
496 0           exit(1);
497             }
498             }
499              
500             }
501 0           return;
502             }
503              
504             ### INTERNAL UTILITY ###
505             # Usage : _set_match_delimiters ( $delimiters )
506             # Purpose : Populate the global delimiters array with
507             # the delimiters to match. (option --match)
508             # Returns : Normally returns to caller or dies
509             # with exit code 1 on user error.
510             # Throws : No
511              
512             sub _set_match_delimiters {
513 0     0     my $EMPTY_STR = q{};
514 0           my $value = shift;
515              
516 0 0         if ( $value eq $EMPTY_STR ) {
    0          
517 0           print "No matching delimiter specified!\n";
518 0           exit(1);
519             }
520             elsif ( $value =~ m/^-/xsm ) {
521 0           print "Invalid --match argument option: '$value'\n";
522 0           exit(1);
523             }
524              
525             # $value contains a comma separated string of delimiters
526 0           chomp $value;
527              
528             # Assign our global array with the delimiters
529 0           @gl_delimiterarray = split( ',', $value );
530              
531 0           return;
532              
533             }
534              
535             ### INTERNAL UTILITY ###
536             # Usage : _print_to_stderr_exit()
537             # Purpose : Print user errors and die.
538             # Returns : No, dies with exit code 1
539             # Throws : No
540              
541             sub _print_to_stderr_exit {
542              
543 0     0     my $href_errmsg = shift;
544 0           print STDERR "$$href_errmsg \n";
545 0           exit(1);
546              
547             }
548              
549             ### INTERNAL UTILITY ###
550             # Usage : _is_lone_cli_dash()
551             # Purpose : Test if @ARGV contains the lone dash ('-').
552             # Returns : True (1) if found, otherwise $EMPTY_STR
553             # Throws : No
554              
555             sub _is_lone_cli_dash {
556              
557 0     0     my @cmdlinearray = @ARGV;
558 0           my $EMPTY_STR = q{};
559              
560 0           my $regex = qr/(\s*-\s*)/; # try to match '-'
561              
562 0           foreach ( 0 .. $#cmdlinearray ) {
563              
564 0 0         if ( $cmdlinearray[$_] =~ $regex ) {
565              
566             # Nothing before and after
567 0 0 0       if ( ( $` eq $EMPTY_STR ) && ( $' eq $EMPTY_STR ) ) {
568              
569             # Found the lone dash
570 0           return 1;
571             }
572             }
573             }
574              
575 0           return $EMPTY_STR;
576             }
577              
578             ### INTERNAL UTILITY ###
579             # Usage : _print_all_delimiters( $line, IS_FILEINFO, IS_UNIQUE )
580             # Purpose : Print the delimiters only. Handles options
581             # --list and --list-unique. The 2nd argument
582             # '$is_with_fileinfo' only apply to --list.
583             # Returns : N/A. Normally returns to caller.
584             # Errors : Dies with exit code 2, internal errors in hd_getstate().
585             # Throws : No
586              
587             sub _print_all_delimiters {
588              
589 0     0     my ( $line, $is_with_fileinfo, $is_unique_list ) = @_;
590 0           my $EMPTY_STR = q{};
591 0           my %state;
592              
593             # Read out the default state label symbols
594 0           my %label = hd_labels();
595              
596             ############## If exception exit(2) ########
597 0           eval { %state = hd_getstate($line); };
  0            
598 0 0         if ($@) {
599 0           my $logcreated = _write_error_file( $@, _get_error_fname() );
600 0 0         if ($logcreated) {
601 0           print STDERR "Fatal internal errors, see file:",
602             _get_error_fname(), "\n";
603             }
604 0           exit(2);
605             }
606             ############################################
607              
608 0 0         if ( $state{blockdelimiter} ne $EMPTY_STR ) {
609              
610             # The delimiter is the terminator on the egress line ('E')
611 0 0         if ( $state{statemarker} eq $label{egress} ) {
612              
613             # Option --list-unique
614 0 0         if ($is_unique_list) {
615              
616             # Add all, will become unique in _print_unique_delimiters()
617 0           push @gl_to_be_unique_delimiters, $state{blockdelimiter};
618             }
619              
620             # Option --list
621             else {
622              
623             # File information not available is pipe or redirect
624 0 0         if ( $ARGV =~ m/^-/xsm ) {
625 0           $is_with_fileinfo = $EMPTY_STR;
626             }
627              
628             # Print the delimiter itself (stored in 'blockdelimiter')
629 0 0         if ($is_with_fileinfo) {
630 0           print "($ARGV:$.)$state{blockdelimiter} \n";
631             }
632             else {
633 0           print "$state{blockdelimiter} \n";
634             }
635             }
636              
637             } # end the last delimiter (at egress)
638              
639             } # end delimiter found in block
640              
641 0           return;
642             }
643              
644             ### INTERNAL UTILITY ###
645             # Usage : _debug_every_line( $line, IS_FILEINFO, IS_ADDLABEL )
646             # Purpose : Print every line for debugging purpose.
647             # Handles option --debug
648             # Returns : N/A. Normally returns to caller.
649             # Errors : Dies with exit code 2, internal errors in hd_getstate().
650             # Throws : No
651              
652             sub _debug_every_line {
653              
654 0     0     my ( $line, $is_with_fileinfo, $is_add_label ) = @_;
655 0           my $EMPTY_STR = q{};
656 0           my %state;
657              
658             ############## If exception exit(2) ########
659 0           eval { %state = hd_getstate($line); };
  0            
660 0 0         if ($@) {
661 0           my $logcreated = _write_error_file( $@, _get_error_fname() );
662 0 0         if ($logcreated) {
663 0           print STDERR "Fatal internal errors, see file:",
664             _get_error_fname(), "\n";
665             }
666 0           exit(2);
667             }
668             ############################################
669              
670             # File information not available is pipe or redirect
671 0 0         if ( $ARGV =~ m/^-/xsm ) {
672 0           $is_with_fileinfo = $EMPTY_STR;
673             }
674              
675             SWITCH: {
676 0 0 0       ( $is_add_label && $is_with_fileinfo ) and do {
  0            
677 0           print "($ARGV:$.)$state{statemarker}]$line";
678 0           last SWITCH;
679             };
680 0 0 0       ( !$is_add_label && $is_with_fileinfo ) and do {
681 0           print "($ARGV:$.)$line";
682 0           last SWITCH;
683             };
684 0 0 0       ( $is_add_label && !$is_with_fileinfo ) and do {
685 0           print "$state{statemarker}]$line";
686 0           last SWITCH;
687             };
688 0 0 0       ( !$is_add_label && !$is_with_fileinfo ) and do {
689 0           print "$line";
690 0           last SWITCH;
691             };
692              
693             }; # switch and combine all variants
694              
695 0           return;
696             }
697              
698             ####################################################
699             # Usage: _print_heredoc();
700             # Purpose: Print (and match lines if set) here document content
701             # Returns: N/A
702             # Parameters: line to analyze, and Getopt boolens
703             # Throws: Yes
704              
705             sub _print_heredoc {
706              
707 0     0     my ( $line, $is_with_fileinfo, $is_add_code ) = @_;
708 0           my $EMPTY_STR = q{};
709              
710             # Read out the default markers symbols
711 0           my %label = hd_labels();
712 0           my %state;
713              
714             ############## If exception exit(2) ########
715 0           eval { %state = hd_getstate($line); };
  0            
716 0 0         if ($@) {
717 0           my $logcreated = _write_error_file( $@, _get_error_fname() );
718 0 0         if ($logcreated) {
719 0           print STDERR "Fatal internal errors, see file:",
720             _get_error_fname(), "\n";
721             }
722 0           exit(2);
723             }
724             ############################################
725              
726 0 0         if ( $state{statemarker} eq $label{heredoc} ) {
727              
728             # File information not available is pipe or redirect
729 0 0         if ( $ARGV =~ m/^-/xsm ) {
730 0           $is_with_fileinfo = $EMPTY_STR;
731             }
732              
733             # Print only here document matching the set delimiters
734 0 0         if (@gl_delimiterarray) {
735              
736 0           foreach my $lineitem (@gl_delimiterarray) {
737              
738 0 0         if ( $state{blockdelimiter} eq $lineitem ) {
739              
740 0           $gl_is_successful_match = 1; # True
741              
742             SWITCH: {
743 0 0 0       ( $is_add_code && $is_with_fileinfo ) and do {
  0            
744 0           print "($ARGV:$.)$state{statemarker}]$line";
745 0           last SWITCH;
746             };
747 0 0 0       ( !$is_add_code && $is_with_fileinfo ) and do {
748 0           print "($ARGV:$.)$line";
749 0           last SWITCH;
750             };
751 0 0 0       ( $is_add_code && !$is_with_fileinfo ) and do {
752 0           print "$state{statemarker}]$line";
753 0           last SWITCH;
754             };
755 0 0 0       ( !$is_add_code && !$is_with_fileinfo ) and do {
756 0           print "$line";
757 0           last SWITCH;
758             };
759              
760             }; # switch and combine all variants
761              
762             } # if match blockdelimiter and item
763              
764             } # end foreach
765              
766             }
767              
768             # Print every line (option --match not used)
769             else {
770              
771             SWITCH: {
772 0 0 0       ( $is_add_code && $is_with_fileinfo ) and do {
  0            
773 0           print "($ARGV:$.)$state{statemarker}]$line";
774 0           last SWITCH;
775             };
776 0 0 0       ( !$is_add_code && $is_with_fileinfo ) and do {
777 0           print "($ARGV:$.)$line";
778 0           last SWITCH;
779             };
780 0 0 0       ( $is_add_code && !$is_with_fileinfo ) and do {
781 0           print "$state{statemarker}]$line";
782 0           last SWITCH;
783             };
784 0 0 0       ( !$is_add_code && !$is_with_fileinfo ) and do {
785 0           print "$line";
786 0           last SWITCH;
787             };
788             }; # switch and combine all variants
789             }
790              
791             } # end here document
792              
793 0           return;
794             }
795              
796             ### INTERNAL UTILITY ###
797             # Usage : _is_cli_with_other_than_option()
798             # Purpose : Test if @ARGV contains any other arguments than
799             # than the lonely dash '-'
800             # Returns : True (1) if found, otherwise $EMPTY_STR
801             # Throws : No
802              
803             sub _is_cli_with_other_than_option {
804              
805 0     0     my $EMPTY_STR = q{};
806 0           my @cmdlinearray = @ARGV;
807              
808             LOOP:
809 0           foreach ( 0 .. $#cmdlinearray ) {
810              
811 0 0         if ( $cmdlinearray[$_] =~ m/(-[a-zA-Z])+/ ) {
812 0           next LOOP;
813             }
814             else {
815 0           return 1; # True, found something trailing the '-'
816             }
817             }
818              
819 0           return $EMPTY_STR; # False, only '-' (or empty @ARGV)
820             }
821              
822             ### INTERNAL UTILITY ###
823             # Usage : _print_unique_delimiters()
824             # Purpose : Print only the unique delimiters.
825             # Returns : Normally returns to caller.
826             # Throws : No
827              
828             sub _print_unique_delimiters {
829 0     0     my $EMPTY_STR = q{};
830 0           my $file = shift;
831 0           my %seen;
832              
833             # Test for option --quiet (i.e. $file is set to $EMPTY_STR)
834 0 0         if ( $file ne $EMPTY_STR ) {
835 0           print "($file)";
836             }
837              
838             # Make unique delimiter list from global array of found delimiters
839 0           my @unique = grep { !$seen{$_}++ } @gl_to_be_unique_delimiters;
  0            
840              
841             # print the unique list
842 0           foreach my $item (@unique) {
843 0           print "$item ";
844             }
845              
846 0           @gl_to_be_unique_delimiters = ();
847              
848 0           return;
849             }
850              
851             ### INTERNAL UTILITY ###
852             # Usage : _write_error_file( $@, $err_filename )
853             # Purpose : Writes the error message to file in user home directory.
854             # Returns : True if file open ok, false otherwise.
855             # Throws : No
856              
857             sub _write_error_file {
858 0     0     my ( $err_str, $log_fname ) = @_;
859 0           my $EMPTY_STR = q{};
860 0           my $log_fh;
861              
862 0 0         open $log_fh, '>>', $log_fname
863             or return $EMPTY_STR;
864              
865 0           print $log_fh "$err_str\n";
866 0           close($log_fh);
867 0           return 1;
868             }
869              
870             ### INTERNAL UTILITY ###
871             # Usage : _get_error_fname()
872             # Purpose : Creates a filename for writing in user home
873             # directory with ISO8601 formated date-time stamp.
874             # Returns : The name of the error file.
875             # Throws : No
876              
877             sub _get_error_fname {
878 0     0     my $err_fname = sprintf '%s-%s.error', "$ENV{HOME}/$SCRIPT",
879             POSIX::strftime( q!%Y-%m-%d-%H.%M.%SZ!, gmtime );
880 0           return $err_fname;
881             }
882              
883             =head1 SYNOPSIS
884              
885             use 5.010;
886             use Filter::Heredoc::App qw( run_filter_heredoc );
887             run_filter_heredoc();
888            
889             =head1 DESCRIPTION
890              
891             This module implements the logic and functions to search and filter
892             here documents in scripts. Support for shell script is more mature than
893             other near compatible languages like Perl. Don't rely on current
894             version code for Perl since it's still in an early development.
895              
896             =head1 SUBROUTINES
897              
898             I exports following subroutine only on request.
899              
900             run_filter_heredoc # runs the filter-heredoc application code
901            
902             =head2 B
903              
904             run_filter_heredoc();
905            
906             This function is called by I and implements the
907             logic and functions to search and filter here documents from the
908             command line.
909              
910             =head1 ERRORS
911              
912             On user errors dies with exit(1). Exceptions for C are
913             trapped and after writing an error file, dies with exit code 2.
914            
915             =head1 BUGS AND LIMITATIONS
916              
917             I understands here documents syntax in *nix
918             shells scripts. Running other script languages will result in an
919             unpredictable output. This is not regarded as a bug.
920              
921             Please report any bugs or feature requests to
922             L or at
923             C<< >>.
924              
925             =head1 AUTHOR
926              
927             Bertil Kronlund, C<< >>
928              
929             =head1 SEE ALSO
930              
931             L, L
932              
933             =head1 LICENSE AND COPYRIGHT
934              
935             Copyright 2011-12, Bertil Kronlund
936              
937             This program is free software; you can redistribute it and/or modify it
938             under the terms of either: the GNU General Public License as published
939             by the Free Software Foundation; or the Artistic License.
940              
941             See http://dev.perl.org/licenses/ for more information.
942              
943             =cut
944              
945             1; # End of Filter::Heredoc::App