XML, the Perl Way

File Coverage

File: tools/xml_merge/xml_merge
Coverage: 85.4%

line stmt bran cond sub pod time code
1 #!/usr/bin/perl -w
2 # $Id: /xmltwig/trunk/tools/xml_merge/xml_merge 12 2007-04-22T06:04:54.627880Z mrodrigu $
3
25
25
25
25
62090
30
662
use strict;
4
5
25
25
25
25
34300
29
170
use XML::Twig;
6
25
25
25
25
6723
14740
1970
use FindBin qw( $RealBin $RealScript);
7
25
25
25
25
26818
558
1187
use Getopt::Std;
8
9
25
1811399
$Getopt::Std::STANDARD_HELP_VERSION=1; # twice to prevent warning with 5.6.1 (I know it's dumb!)
10
25
27
$Getopt::Std::STANDARD_HELP_VERSION=1; # to stop processing after --help or --version
11
12
25
25
25
25
71
23
30077
use vars qw( $VERSION $USAGE);
13
14
25
36
$VERSION= "0.02";
15
25
31
$USAGE= "xml_merge [-o <output_file>] [-i] [-v] [-h] [-m] [-V] [file]\n";
16
17 { # main block
18
19
25
25
25
35
my $opt={};
20
25
67
getopts('o:ivhmV', $opt);
21
22
25
1
100
840
0
if( $opt->{h}) { die $USAGE, "\n"; }
23
24
1
100
50
0
if( $opt->{m}) { exec "pod2text $RealBin/$RealScript"; }
24
23
1
1
100
42
24
0
if( $opt->{V}) { print "xml_merge version $VERSION\n"; exit; }
25
26
22
100
49
if( $opt->{o})
27
21
50
952
  { open( my $out, '>', $opt->{o}) or die "cannot create $opt->{o}: $!";
28
21
44
    $opt->{fh}= $out; # used to set twig_print_outside_roots
29   }
30 else
31
1
2
  { $opt->{fh}= 1; } # this way twig_print_outside_roots outputs to STDOUT
32
33
22
28
$opt->{subdocs} = 1;
34
22
33
$opt->{file} = $ARGV[0];
35
36
24
24
39
$opt->{twig_roots}= $opt->{i} ? { 'xi:include' => sub { $opt->{file}= $_->att( 'href');
37
24
1
100
58
4
                                                        if( $_->att( 'subdocs')) { merge( $opt); }
38
23
27
                                                        else { spit( $opt); }
39                                                       },
40                                 }
41
59
59
94
                              : { '?merge' => sub { $opt= parse( $_->data, $opt);
42
59
1
100
94
8
                                                        if( $opt->{subdocs}) { merge( $opt); }
43
58
80
                                                        else { spit( $opt); }
44                                                       },
45                                 }
46
47
22
100
131
                              ;
48
49
22
42
merge( $opt);
50
51
22
0
50
0
0
if( $opt->{v}) { warn "done\n"; }
52
53 }
54
55 sub merge
56
24
24
28
  { my( $opt)= @_;
57
24
102
    my $t= XML::Twig->new( keep_encoding => 1, keep_spaces => 1,
58                            twig_roots => $opt->{twig_roots},
59                            twig_print_outside_roots => $opt->{fh},
60                          );
61
24
0
50
33
60
0
    if( $opt->{v} && $opt->{file}) { warn "merging $opt->{file} (parsing)\n"; }
62
24
24
0
50
51
55
0
    if( $opt->{file}) { $t->parsefile( $opt->{file}); } else { $t->parse( \*STDIN); }
63   }
64
65 sub spit
66
81
81
65
  { my( $opt)= @_;
67
81
0
50
33
143
0
    if( $opt->{v} && $opt->{file}) { warn "merging $opt->{file} (no parsing)\n"; }
68
81
50
1047
    open( my $in, '<', $opt->{file}) or die "cannot open sub document '$opt->{file}': $!";
69
81
608
    while( <$in>)
70
308
100
100
911
      { next if( m{^\Q<?xml version} || m{^\s*</?xml_split:root});
71
250
240
240
10
100
234
120
653
13
        if( $opt->{o}) { print {$opt->{fh}} $_; } else { print $_; }
72       }
73
81
586
    close $in;
74   }
75
76 # data is the pi data,
77 # (ugly) format is keyword1 = val1 : keyword2 = val2 ... : filename
78 # ex: subdoc = 1 : file-01.xml
79
80 sub parse
81
59
59
51
  { my( $data, $opt)= @_;
82
59
59
246
201
    while( $data=~ s{^\s*(\S+)\s*=\s*(\S+)\s*:\s*}{}) { $opt->{$1}= $2; }
83
59
51
    $opt->{file}= $data;
84
59
59
    return $opt;
85   }
86
87
88 # for Getop::Std
89
0
0
sub HELP_MESSAGE { return $USAGE; }
90
0
0
sub VERSION_MESSAGE { return $VERSION; }
91