contrib/glilypond/args.pl

   1 ########################################################################
   2 # Legalese
   3 ########################################################################
   4
   5 my $License = q*
   6 groff_lilypond - integrate `lilypond' into `groff' files
   7
   8 Source file position: `<groff-source>/contrib/glilypond/args.pl'
   9 Installed position: `<prefix>/lib/groff/glilypond'
  10
  11 Copyright (C) 2013-2014 Free Software Foundation, Inc.
  12   Written by Bernd Warken <groff-bernd.warken-72@web.de>
  13
  14 This file is part of `GNU groff'.
  15
  16   `GNU groff' is free software: you can redistribute it and/or modify it
  17 under the terms of the `GNU General Public License' as published by the
  18 `Free Software Foundation', either version 3 of the License, or (at your
  19 option) any later version.
  20
  21   `GNU groff' is distributed in the hope that it will be useful, but
  22 WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the `GNU
  24 General Public License' for more details.
  25
  26   You should have received a copy of the 'GNU General Public License`
  27 along with `groff', see the files `COPYING' and `LICENSE' in the top
  28 directory of the `groff' source package.  If not, see
  29 <http://www.gnu.org/licenses/>.
  30 *;
  31
  32 ##### end legalese
  33
  34
  35 # use strict;
  36 # use warnings;
  37 # use diagnostics;
  38
  39 use integer;
  40
  41 our ( $Globals, $Args, $stderr, $v, $out );
  42
  43 # ----------
  44 # subs for second run, for remaining long options after splitting and
  45 # transfer
  46 # ----------
  47
  48 my %opts_with_arg =
  49   (
  50
  51    '--eps_dir' => sub {
  52      $Args->{'eps_dir'} = shift;
  53    },
  54
  55    '--output' => sub {
  56      $Args->{'output'} = shift;
  57    },
  58
  59    '--prefix' => sub {
  60      $Args->{'prefix'} = shift;
  61    },
  62
  63    '--temp_dir' => sub {
  64      $Args->{'temp_dir'} = shift;
  65    },
  66
  67   );                            # end of %opts_with_arg
  68
  69
  70 my %opts_noarg =
  71   (
  72
  73    '--help' => sub {
  74      &usage;
  75      exit;
  76    },
  77
  78    '--keep_all' => sub {
  79      $Args->{'keep_all'} = TRUE;
  80    },
  81
  82    '--license' => sub {
  83      &license;
  84      exit;
  85    },
  86
  87    '--ly2eps' => sub {
  88      $Args->{'eps_func'} = 'ly';
  89    },
  90
  91    '--pdf2eps' => sub {
  92      $Args->{'eps_func'} = 'pdf';
  93    },
  94
  95    '--verbose' => sub {
  96      $Args->{'verbose'} = TRUE;
  97    },
  98
  99    '--version' => sub {
 100      &version;
 101      exit;
 102    },
 103
 104   );                            # end of %opts_noarg
 105
 106
 107 # used variables in both runs
 108
 109 my @files = EMPTYARRAY;
 110
 111
 112 #----------
 113 # first run for command line arguments
 114 #----------
 115
 116 # global variables for first run
 117
 118 my @splitted_args;
 119 my $double_minus = FALSE;
 120 my $arg = EMPTYSTRING;
 121 my $has_arg = FALSE;
 122
 123
 124 # Split short option collections and transfer these to suitable long
 125 # options from above.  Note that `-v' now means `--verbose' in version
 126 # `v1.1', earlier versions had `--version' for `-v'.
 127
 128 my %short_opts =
 129   (
 130    '?' => '--help',
 131    'e' => '--eps_dir',
 132    'h' => '--help',
 133    'l' => '--license',
 134    'k' => '--keep_all',
 135    'o' => '--output',
 136    'p' => '--prefix',
 137    't' => '--temp_dir',
 138    'v' => '--verbose',
 139    'V' => '--verbose',
 140   );
 141
 142
 143 # transfer long option abbreviations to the long options from above
 144
 145 my @long_opts;
 146
 147 $long_opts[3] =
 148   {                             # option abbreviations of 3 characters
 149    '--e' => '--eps_dir',
 150    '--f' => '--prefix',         # --f for --file_prefix
 151    '--h' => '--help',
 152    '--k' => '--keep_all',       # and --keep_files
 153    '--o' => '--output',
 154    '--p' => '--prefix',         # and --file_prefix
 155    '--t' => '--temp_dir',
 156    '--u' => '--help',           # '--usage' is mapped to `--help'
 157   };
 158
 159 $long_opts[4] =
 160   {                             # option abbreviations of 4 characters
 161    '--li' => '--license',
 162    '--ly' => '--ly2eps',
 163    '--pd' => '--pdf2eps',
 164    '--pr' => '--prefix',
 165   };
 166
 167 $long_opts[6] =
 168   {                             # option abbreviations of 6 characters
 169    '--verb' => '--verbose',
 170    '--vers' => '--version',
 171   };
 172
 173
 174 # subs for short splitting and replacing long abbreviations
 175
 176 my $split_short = sub {
 177
 178   my @chars = split //, $1;     # omit leading dash
 179
 180      # if result is TRUE: run `next SPLIT' afterwards
 181
 182    CHARS: while ( @chars ) {
 183        my $c = shift @chars;
 184
 185        unless ( exists $short_opts{$c} ) {
 186          $stderr->print( "Unknown short option `-$c'." );
 187          next CHARS;
 188        }
 189
 190        # short option exists
 191
 192        # map or transfer to special long option from above
 193        my $transopt = $short_opts{$c};
 194
 195        if ( exists $opts_noarg{$transopt} ) {
 196          push @splitted_args, $transopt;
 197          $Args->{'verbose'}  = TRUE if ( $transopt eq '--verbose' );
 198          next CHARS;
 199        }
 200
 201        if ( exists $opts_with_arg{$transopt} ) {
 202          push @splitted_args, $transopt;
 203
 204          if ( @chars ) {
 205            # if @chars is not empty, option $transopt has argument
 206            # in this arg, the rest of characters in @chars
 207            push @splitted_args, join "", @chars;
 208            @chars = EMPTYARRAY;
 209            return TRUE;         # use `next SPLIT' afterwards
 210          }
 211
 212          # optarg is the next argument
 213          $has_arg = $transopt;
 214          return TRUE;           # use `next SPLIT' afterwards
 215        }                        # end of if %opts_with_arg
 216      }                          # end of while CHARS
 217      return FALSE;              # do not do anything
 218 };                              # end of sub for short_opt_collection
 219
 220
 221 my $split_long = sub {
 222   my $from_arg = shift;
 223   $from_arg =~ /^([^=]+)/;
 224   my $opt_part = lc($1);
 225   my $optarg = undef;
 226   if ( $from_arg =~ /=(.*)$/ ) {
 227     $optarg = $1;
 228   }
 229
 230  N: for my $n ( qw/6 4 3/ ) {
 231     $opt_part =~ / # match $n characters
 232                    ^
 233                    (
 234                      .{$n}
 235                    )
 236                  /x;
 237     my $argn = $1;              # get the first $n characters
 238
 239     # no match, so luck for fewer number of chars
 240     next N unless ( $argn );
 241
 242     next N unless ( exists $long_opts[$n]->{$argn} );
 243     # not in $n hash, so go on to next loop for $n
 244
 245     # now $n-hash has arg
 246
 247     # map or transfer to special long opt from above
 248     my $transopt = $long_opts[$n]->{$argn};
 249
 250     # test on option without arg
 251     if ( exists $opts_noarg{$transopt} ) { # opt has no arg
 252       $stderr->print( 'Option ' . $transopt . 'has no argument: ' .
 253                       $from_arg . '.' ) if ( defined($optarg) );
 254       push @splitted_args, $transopt;
 255       $Args->{'verbose'} = TRUE if ( $transopt eq '--verbose' );
 256       return TRUE;              # use `next SPLIT' afterwards
 257     }                           # end of if %opts_noarg
 258
 259     # test on option with arg
 260     if ( exists $opts_with_arg{$transopt} ) { # opt has arg
 261       push @splitted_args, $transopt;
 262
 263       # test on optarg in arg
 264       if ( defined($optarg) ) {
 265         push @splitted_args, $1;
 266         return TRUE; # use `next SPLIT' afterwards
 267       } # end of if optarg in arg
 268
 269       # has optarg in next arg
 270       $has_arg = $transopt;
 271       return TRUE; # use `next SPLIT' afterwards
 272     } # end of if %opts_with_arg
 273
 274     # not with and without option, so is not permitted
 275     $stderr->print( "`" . $transopt .
 276                     "' is unknown long option from `" . $from_arg . "'" );
 277     return TRUE; # use `next SPLIT' afterwards
 278   } # end of for N
 279   return FALSE; # do nothing
 280 }; # end of split_long()
 281
 282
 283 #----------
 284 # do split and transfer arguments
 285 #----------
 286 sub run_first {
 287
 288  SPLIT: foreach (@ARGV) {
 289     # Transform long and short options into some given long options.
 290     # Split long opts with arg into 2 args (no `=').
 291     # Transform short option collections into given long options.
 292     chomp;
 293
 294     if ( $has_arg ) {
 295       push @splitted_args, $_;
 296       $has_arg = EMPTYSTRING;
 297       next SPLIT;
 298     }
 299
 300     if ( $double_minus ) {
 301       push @files, $_;
 302       next SPLIT;
 303     }
 304
 305     if ( $_ eq '-' ) {          # file arg `-'
 306       push @files, $_;
 307       next SPLIT;
 308     }
 309
 310     if ( $_ eq '--' ) {         # POSIX arg `--'
 311       push @splitted_args, $_;
 312       $double_minus = TRUE;
 313       next SPLIT;
 314     }
 315
 316     if ( / # short option or collection of short options
 317            ^
 318            -
 319            (
 320              [^-]
 321              .*
 322            )
 323            $
 324          /x ) {
 325       $split_short->($1);
 326       next SPLIT;
 327     }                           # end of short option
 328
 329     if ( /^--/ ) {              # starts with 2 dashes, a long option
 330       $split_long->($_);
 331       next SPLIT;
 332     }                           # end of long option
 333
 334     # unknown option without leading dash is a file name
 335     push @files, $_;
 336     next SPLIT;
 337   }                             # end of foreach SPLIT
 338
 339                                 # all args are considered
 340   $stderr->print( "Option `$has_arg' needs an argument." )
 341     if ( $has_arg );
 342
 343
 344   push @files, '-' unless ( @files );
 345   @ARGV = @splitted_args;
 346
 347 };                  # end of first run, splitting with map or transfer
 348
 349
 350 #----------
 351 # open or ignore verbose output
 352 #----------
 353 sub install_verbose {
 354   if ( $Args->{'verbose'} ) { # `--verbose' was used
 355     # make verbose output into $v
 356     my $s = $v->get(); # get content of string so far as array ref, close
 357
 358     $v = new FH_STDERR(); # make verbose output into STDERR
 359     if ( $s ) {
 360       for ( @$s ) {
 361         # print the file content into new verbose output
 362         $v->print($_);
 363       }
 364     }
 365     # verbose output is now active (into STDERR)
 366     $v->print( "Option `-v' means `--verbose'." );
 367     $v->print( "Version information is printed by option `--version'." );
 368     $v->print( "#" x 72 );
 369
 370   } else { # `--verbose' was not used
 371     # do not be verbose, make verbose invisible
 372
 373     $v->close(); # close and ignore the string content
 374
 375     $v = new FH_NULL();
 376     # this is either into /dev/null or in an ignored string
 377
 378   } # end if-else about verbose
 379   # `$v->print' works now in any case
 380
 381   $v->print( "Verbose output was chosen." );
 382
 383   my $s = $Globals->{'prog_is_installed'} ? '' : ' not';
 384   $v->print( $Globals->{'prog'} . " is" . $s .
 385              " installed." );
 386
 387   $v->print( 'The command line options are:' );
 388
 389   $s = "  options:";
 390   $s .= " `" . $_ . "'" for ( @ARGV );
 391   $v->print( $s );
 392
 393   $s = "  file names:";
 394   $s .= " `" . $_ . "'\n" for ( @files );
 395   $v->print( $s );
 396 } # end install_verbose()
 397
 398
 399 #----------
 400 # second run of command line arguments
 401 #----------
 402 sub run_second {
 403     # Second run of args with new @ARGV from the former splitting.
 404     # Arguments are now splitted and transformed into special long options.
 405
 406     my $double_minus = FALSE;
 407     my $has_arg = FALSE;
 408
 409   ARGS: for my $arg ( @ARGV ) {
 410
 411       # ignore `--', file names are handled later on
 412       last ARGS if ( $arg eq '--' );
 413
 414       if ( $has_arg ) {
 415         unless ( exists $opts_with_arg{$has_arg} ) {
 416           $stderr->print( "`\%opts_with_args' does not have key `" .
 417                             $has_arg . "'." );
 418           next ARGS;
 419         }
 420
 421         $opts_with_arg{$has_arg}->($arg);
 422         $has_arg = FALSE;
 423         next ARGS;
 424       } # end of $has_arg
 425
 426       if ( exists $opts_with_arg{$arg} ) {
 427         $has_arg = $arg;
 428         next ARGS;
 429       }
 430
 431       if ( exists $opts_noarg{$arg} ) {
 432         $opts_noarg{$arg}->();
 433         next ARGS;
 434       }
 435
 436       # not a suitable option
 437       $stderr->print( "Wrong option `" . $arg . "'." );
 438       next ARGS;
 439
 440     } # end of for ARGS:
 441
 442
 443     if ( $has_arg ) { # after last argument
 444       die "Option `$has_arg' needs an argument.";
 445     }
 446
 447   }; # end of second run
 448
 449
 450 sub handle_args {
 451   # handling the output of args
 452
 453   if ( $Args->{'output'} ) { # `--output' was set in the arguments
 454     my $out_path = &path2abs($Args->{'output'});
 455     die "Output file name $Args->{'output'} cannot be used."
 456       unless ( $out_path );
 457
 458     my ( $file, $dir );
 459     ( $file, $dir ) = File::Basename::fileparse($out_path)
 460       or die "Could not handle output file path `" . $out_path . "': " .
 461         "directory name `" . $dir . "' and file name `" . $file . "'.";
 462
 463     die "Could not find output directory for `" . $Args->{'output'} . "'"
 464       unless ( $dir );
 465     die "Could not find output file: `" . $Args->{'output'} .
 466       "'" unless ( $file );
 467
 468     if ( -d $dir ) {
 469       die "Could not write to output directory `" . $dir . "'."
 470         unless ( -w $dir );
 471     } else {
 472       $dir = &make_dir($dir);
 473       die "Could not create output directory in: `" . $out_path . "'."
 474         unless ( $dir );
 475     }
 476
 477     # now $dir is a writable directory
 478
 479     if ( -e $out_path ) {
 480       die "Could not write to output file `" . $out_path . "'."
 481         unless ( -w $out_path );
 482     }
 483
 484     $out = new FH_FILE( $out_path );
 485     $v->print( "Output goes to file `" . $out_path . "'." );
 486   } else { # `--output' was not set
 487     $out = new FH_STDOUT();
 488   }
 489   # no $out is the right behavior for standard output
 490
 491 #  $Args->{'prefix'} .= '_' . $Args->{'eps_func'} . '2eps';
 492
 493   @ARGV = @files;
 494 }
 495
 496
 497 1;
 498 ########################################################################
 499 ### Emacs settings
 500 # Local Variables:
 501 # mode: CPerl
 502 # End: