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