share/extensions/SpSVG.pm

   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 #
  26
  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
  33
  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.
  46
  47 #use SVG;
  48 #use SVG::Parser;
  49
  50 use XML::XQL;
  51 use XML::XQL::DOM;
  52
  53 use vars qw(@ISA @EXPORT $VERSION);
  54
  55 $VERSION = 1.02; # fixme: use SpSVG 1.01 doesn't raise exception.
  56 @ISA = qw(Exporter);
  57
  58 # Symbols
  59 @EXPORT = qw(
  60
  61 );
  62
  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
  69
  70         ids     => [],       # Array of ids that will be iterated over
  71                              # in process()
  72         svg     => '',       # SVG document object
  73
  74     };
  75     bless $self;
  76 }
  77
  78 sub parse {
  79     my $self = shift;
  80
  81     my $infile = $self->{'opts'}->{'file'};
  82
  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     }
  96
  97
  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 }
 104
 105 # Return SVG document as a string
 106 sub get {
 107     my $self = shift;
 108     my $string =  $self->{'svg'}->toString;
 109
 110 }
 111
 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 }
 125
 126 sub process_ids {
 127     my $self = shift;
 128     my $func = shift;
 129
 130     my @ids = @{$self->{'ids'}};
 131
 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.
 140
 141         # Call the user function on the node identified by $id
 142         my $new_node = $func->($node->toString);
 143
 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/;
 150
 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     }
 156
 157
 158 }
 159
 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     );
 174
 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;
 181
 182 }
 183
 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 }
 207
 208 # Parse command line options
 209 sub get_opts {
 210     my $self = shift;
 211     my @user_opt_desc = @_;
 212
 213     my @opt_desc = (
 214         {
 215             opt => 'help|h',
 216             desc => 'Display this help and exit.',
 217         },
 218
 219         {
 220             opt => 'version|v',
 221             desc => 'Print version and exit.',
 222         },
 223
 224         {
 225             opt => 'file|F=s',
 226             desc => 'Input file (default: STDIN).',
 227         },
 228
 229         {
 230             opt => 'output|o=s',
 231             desc => 'Output file (default: STDOUT).',
 232         },
 233
 234         {
 235             opt => 'id=s@',
 236             desc => 'svg id to operate on (can be multiple).',
 237         },
 238
 239         {
 240             opt => 'ids=s',
 241             desc => 'Comma-separated list of svg ids to operate on.',
 242         },
 243     );
 244
 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);
 248
 249     # Append user options
 250     foreach (@user_opt_vals) {
 251         push @opt_vals, $_;
 252     }
 253
 254     # Where the parsed options are stored
 255     my %opts;
 256
 257     #exit 0;
 258
 259     # Parse all options
 260     GetOptions(\%opts, @opt_vals) or usage();
 261
 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     }
 267
 268     # Display usage etc. (and exit)
 269     exists $opts{'version'} && $self->version();
 270     exists $opts{'help'} && $self->usage();
 271
 272     # Save id values for later processing
 273     $self->{'ids'} = \@ids;
 274
 275     # Save options
 276     $self->{'opts'} = \%opts;
 277
 278     # Return the options to script
 279     return %opts;
 280 }
 281
 282 # Exit with named exit status
 283 sub error {
 284     my $self = shift;
 285     my $error_name = shift;
 286     my $script_error_msg = shift || '';
 287
 288     my %status = %{$self->{'status'}};
 289
 290     foreach (keys %status) {
 291         if ($status{$_}[0] eq $error_name) {
 292             $! = $_; # Set exit status
 293
 294             # Commented out; let sodipodi handle the error code instead
 295             #my $msg =  ($status{$_}->[1] . ": $script_error_msg");
 296
 297             my $msg =  "$script_error_msg";
 298             die $msg;
 299         }
 300     }
 301
 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 }
 306
 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 }
 313
 314 sub set_name {
 315     my $self = shift;
 316     my $name = shift || die "No script name supplied!\n";
 317     $self->{'name'} = $name;
 318 }
 319
 320 # Print usage and exit
 321 sub usage {
 322     my $self = shift;
 323     print "Usage: $self->{'name'} OPTIONS FILE\n";
 324     print $self->{'usage'};
 325
 326     my @opt_help = @{$self->{'opt_help'}};
 327     foreach (@opt_help) {
 328         print pad($_->[0]) . $_->[1] . "\n";
 329     }
 330
 331     exit ARG_ERR();
 332 }
 333
 334 sub pad {
 335     my $string = shift;
 336     my $width = '20';
 337     return $string . ' ' x ($width - length($string));
 338 }
 339
 340 # Print version
 341 sub version {
 342     print "Uses SpSVG version $VERSION\n";
 343     exit ARG_ERR();
 344 }
 345
 346 # End of module; return something true
 347 1;
 348
 349 __END__
 350
 351 DOCUMENTATION HERE