1 #!/usr/bin/env perl -w
2 #
3 # SpSVG
4 #
5 # Perl module for sodipodi extensions
6 #
7 # This is a temporary hack that provides the following:
8 # * Some standard getopts (help, i/o, ids)
9 # * A way to exit that produces the error codes outlined in
10 # the extension specs (SpSVG::error)
11 # * A method that takes a function as its arguments and passes
12 # each specified element ('--id=foo --id=bar', 'ids=fooz,baaz',
13 # and so forth) as plain text to the function. The function is
14 # expected to return the processed version of this text.
15 #
16 # TODO:
17 #
18 # * Write POD
19 # * Exit with a friendly message if XML::XQL isn't installed
20 # * Decide how to implement the module interface
21 # * Move from XML::XQL to SVG/SVG::Parser (see below)
22 # * Make the process method more efficient (again, see below)
23 #
24 # Authors: Daniel Goude (goude@dtek.chalmers.se)
25 #
27 package SpSVG; # Think of a better name
28 use strict;
29 #use Carp;
30 use Exporter;
31 use Getopt::Long;
32 #use Data::Dumper; # For debugging
34 # From the SVG.pm documentation (actually
35 # http://roasp.com/tutorial/tutorial6.shtml):
36 #
37 # > Currently, version 2.0 of SVG.pm does not internally support DOM
38 # > traversiong functionality such as getting the children,siblings,or
39 # > parent of an element, so the interaction capability between SVG::Parser
40 # > and SVG is limited to manipulations of a known image. The next version
41 # > of SVG will support all these and more key functions which will make
42 # > SVG::Parser extremely useful.
43 #
44 # I plan to replace the /XML::XQL(::DOM)?/ code as soon as this is
45 # fixed.
47 #use SVG;
48 #use SVG::Parser;
50 use XML::XQL;
51 use XML::XQL::DOM;
53 use vars qw(@ISA @EXPORT $VERSION);
55 $VERSION = 1.02; # fixme: use SpSVG 1.01 doesn't raise exception.
56 @ISA = qw(Exporter);
58 # Symbols
59 @EXPORT = qw(
61 );
63 sub new {
64 my $self = {
65 status => make_status(),
66 name => '', # Name of script
67 usage => '', # Usage string
68 opt_help => [], # Used for --help
70 ids => [], # Array of ids that will be iterated over
71 # in process()
72 svg => '', # SVG document object
74 };
75 bless $self;
76 }
78 sub parse {
79 my $self = shift;
81 my $infile = $self->{'opts'}->{'file'};
83 my $xml;
84 {
85 local $/=undef;
86 if ($infile) {
87 open (IN, $infile) or
88 $self->error('IO_ERR', "Can't open $infile: $!\n");
89 $xml = <IN>;
90 close IN or
91 $self->error('IO_ERR', "Can't close $infile: $!\n");
92 } else {
93 $xml = <>;
94 }
95 }
98 $self->{'parser'} = new XML::DOM::Parser;
99 my $parser = $self->{'parser'};
100 my $svg = $parser->parse($xml) ||
101 $self->error('INPUT_ERR', "Couldn't parse input: $!.");
102 $self->{'svg'} = $svg;
103 }
105 # Return SVG document as a string
106 sub get {
107 my $self = shift;
108 my $string = $self->{'svg'}->toString;
110 }
112 # Print to $outfile|STDOUT
113 sub dump {
114 my $self = shift;
115 my $outfile = $self->{'opts'}->{'output'};
116 if ($outfile) {
117 open(OUT, ">$outfile") or
118 $self->error('IO_ERR', "Can't open $outfile for writing: $!\n");
119 print OUT $self->get;
120 close OUT or $self->error('IO_ERR', "Can't close $outfile: $!\n");
121 } else {
122 print $self->get;
123 }
124 }
126 sub process_ids {
127 my $self = shift;
128 my $func = shift;
130 my @ids = @{$self->{'ids'}};
132 # Apply a user supplied function to each id
133 foreach my $id (@ids) {
134 my $svg = $self->{'svg'};
135 #warn "ID: $id\n";
136 my @nodes = $svg->xql("//*[\@id = '$id']") or
137 $self->error('NOOP_ERR', "Couldn't find element $id.");
138 my $node = shift @nodes; # Ids are unique
139 # fixme: Add more checking.
141 # Call the user function on the node identified by $id
142 my $new_node = $func->($node->toString);
144 # Replace the comment with user generated SVG
145 my $parent = $node->getParentNode;
146 my $comment = $svg->createComment('SpSVG');
147 $parent->replaceChild($comment, $node);
148 my $output = $self->{'svg'}->toString;
149 $output =~ s/<!--SpSVG-->/$new_node/;
151 # Here the whole (new) document is parsed. Probably VERY inefficient,
152 # but at least you get syntax checking for free..
153 $self->{'svg'} = $self->{'parser'}->parse($output);
154 #print $self->{'svg'}->toString;
155 }
158 }
160 # Exit status codes
161 sub make_status {
162 my $self = shift;
163 my %status = (
164 0 => ["SUCCESS", "Extension exited gracefully"],
165 1 => ["GEN_FAIL", "General failure"],
166 2 => ["MEM_ERR", "Memory error"],
167 3 => ["IO_ERR", "File I/O error"],
168 4 => ["MATH_ERR", "Math error"],
169 5 => ["INPUT_ERR", "Input not understood (not valid SVG)"],
170 6 => ["NOOP_ERR", "Could not operate on any objects in this " .
171 "data stream"],
172 7 => ["ARG_ERR", "Incorrect script arguments"]
173 );
175 # Generate error subs dynamically
176 foreach my $exit_code (sort keys %status) {
177 eval "sub $status{$exit_code}[0] { $exit_code; }";
178 die $@ if $@;
179 }
180 return \%status;
182 }
184 # Create an option array suitable for Getopt::Long
185 sub make_opt_vals {
186 my $self = shift;
187 my @opt_desc = @_;
188 my @opt_vals;
189 my @opt_help = @{$self->{'opt_help'}};
190 foreach (@opt_desc) {
191 my %h = %$_;
192 foreach my $key (keys %h) {
193 #print "Key : $h{$key}\n";
194 if ($key eq 'opt') {
195 push @opt_vals, $h{'opt'};
196 } elsif ($key eq 'desc') {
197 my $option = $h{'opt'};
198 $option =~ s/([^=]+)=.+/$1/;
199 $option =~ s/([^|]+)/(length "$1" > 1 ? '--' : '-') . "$1"/eg;
200 push @opt_help, [$option, $h{'desc'}];
201 }
202 }
203 }
204 $self->{'opt_help'} = \@opt_help;
205 return @opt_vals;
206 }
208 # Parse command line options
209 sub get_opts {
210 my $self = shift;
211 my @user_opt_desc = @_;
213 my @opt_desc = (
214 {
215 opt => 'help|h',
216 desc => 'Display this help and exit.',
217 },
219 {
220 opt => 'version|v',
221 desc => 'Print version and exit.',
222 },
224 {
225 opt => 'file|F=s',
226 desc => 'Input file (default: STDIN).',
227 },
229 {
230 opt => 'output|o=s',
231 desc => 'Output file (default: STDOUT).',
232 },
234 {
235 opt => 'id=s@',
236 desc => 'svg id to operate on (can be multiple).',
237 },
239 {
240 opt => 'ids=s',
241 desc => 'Comma-separated list of svg ids to operate on.',
242 },
243 );
245 # Create option arrays for Getopt::Long
246 my @opt_vals = $self->make_opt_vals(@opt_desc);
247 my @user_opt_vals = $self->make_opt_vals(@user_opt_desc);
249 # Append user options
250 foreach (@user_opt_vals) {
251 push @opt_vals, $_;
252 }
254 # Where the parsed options are stored
255 my %opts;
257 #exit 0;
259 # Parse all options
260 GetOptions(\%opts, @opt_vals) or usage();
262 # Handle comma-separated 'ids=foo,bar'
263 my @ids = @{$opts{'id'}} if $opts{'id'};
264 if (exists $opts{'ids'} && $opts{'ids'} =~ /[\w\d_]+(,[\w\d_]+)*/) {
265 push (@ids, split(/,/, $opts{'ids'}));
266 }
268 # Display usage etc. (and exit)
269 exists $opts{'version'} && $self->version();
270 exists $opts{'help'} && $self->usage();
272 # Save id values for later processing
273 $self->{'ids'} = \@ids;
275 # Save options
276 $self->{'opts'} = \%opts;
278 # Return the options to script
279 return %opts;
280 }
282 # Exit with named exit status
283 sub error {
284 my $self = shift;
285 my $error_name = shift;
286 my $script_error_msg = shift || '';
288 my %status = %{$self->{'status'}};
290 foreach (keys %status) {
291 if ($status{$_}[0] eq $error_name) {
292 $! = $_; # Set exit status
294 # Commented out; let sodipodi handle the error code instead
295 #my $msg = ($status{$_}->[1] . ": $script_error_msg");
297 my $msg = "$script_error_msg";
298 die $msg;
299 }
300 }
302 # Will not be reached unless an improper error_name is given
303 $! = 255; # Exit status
304 warn "Illegal error code '$error_name' called from script\n";
305 }
307 # Some accessor methods
308 sub set_usage {
309 my $self = shift;
310 my $usage = shift || die "No usage string supplied!\n";
311 $self->{'usage'} = $usage;
312 }
314 sub set_name {
315 my $self = shift;
316 my $name = shift || die "No script name supplied!\n";
317 $self->{'name'} = $name;
318 }
320 # Print usage and exit
321 sub usage {
322 my $self = shift;
323 print "Usage: $self->{'name'} OPTIONS FILE\n";
324 print $self->{'usage'};
326 my @opt_help = @{$self->{'opt_help'}};
327 foreach (@opt_help) {
328 print pad($_->[0]) . $_->[1] . "\n";
329 }
331 exit ARG_ERR();
332 }
334 sub pad {
335 my $string = shift;
336 my $width = '20';
337 return $string . ' ' x ($width - length($string));
338 }
340 # Print version
341 sub version {
342 print "Uses SpSVG version $VERSION\n";
343 exit ARG_ERR();
344 }
346 # End of module; return something true
347 1;
349 __END__
351 DOCUMENTATION HERE