contrib/glilypond/glilypond.pl

   1 #! /usr/bin/env perl
   2
   3 package main;
   4
   5 ########################################################################
   6 # debugging
   7 ########################################################################
   8
   9 # See `Mastering Perl', chapter 4.
  10
  11 # use strict;
  12 # use warnings;
  13 # use diagnostics;
  14
  15 use Carp;
  16 $SIG[__DIE__] = sub { &Carp::croak; };
  17
  18 use Data::Dumper;
  19
  20 ########################################################################
  21 # Legalese
  22 ########################################################################
  23
  24 our $Legalese;
  25
  26 {
  27   use constant VERSION => 'v1.3.1'; # version of glilypond
  28
  29 ### This constant `LICENSE' is the license for this file `GPL' >= 2
  30   use constant LICENSE => q*
  31 glilypond - integrate `lilypond' into `groff' files
  32
  33 Source file position: `<groff-source>/contrib/glilypond/glilypond.pl'
  34 Installed position: `<prefix>/bin/glilypond'
  35
  36 Copyright (C) 2013-2014 Free Software Foundation, Inc.
  37   Written by Bernd Warken <groff-bernd.warken-72@web.de>
  38
  39 This file is part of `GNU groff'.
  40
  41   `GNU groff' is free software: you can redistribute it and/or modify it
  42 under the terms of the `GNU General Public License' as published by the
  43 `Free Software Foundation', either version 2 of the License, or (at your
  44 option) any later version.
  45
  46   `GNU groff' is distributed in the hope that it will be useful, but
  47 WITHOUT ANY WARRANTY; without even the implied warranty of
  48 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the `GNU
  49 General Public License' for more details.
  50
  51   You should have received a copy of the 'GNU General Public License`
  52 along with `groff', see the files `COPYING' and `LICENSE' in the top
  53 directory of the `groff' source package.  If not, see
  54 <http://www.gnu.org/licenses/>.
  55 *;
  56
  57
  58   $Legalese =
  59     {
  60      'version' => VERSION,
  61      'license' => LICENSE,
  62     }
  63
  64 }
  65
  66 ##### end legalese
  67
  68
  69 ########################################################################
  70 # global variables and BEGIN
  71 ########################################################################
  72
  73 use integer;
  74 use utf8;
  75
  76 use Cwd qw[];
  77 use File::Basename qw[];
  78 use File::Copy qw[];
  79 use File::HomeDir qw[];
  80 use File::Spec qw[];
  81 use File::Path qw[];
  82 use File::Temp qw[];
  83 use FindBin qw[];
  84 use POSIX qw[];
  85
  86
  87 BEGIN {
  88
  89   use constant FALSE => 0;
  90   use constant TRUE => 1;
  91   use constant EMPTYSTRING => '';
  92   use constant EMPTYARRAY => ();
  93   use constant EMPTYHASH => ();
  94
  95   our $Globals =
  96     {
  97      'before_make' => FALSE,
  98      'groff_version' => EMPTYSTRING,
  99      'prog' => EMPTYSTRING,
 100     };
 101
 102   {
 103     ( my $volume, my $directory, $Globals->{'prog'} ) =
 104       File::Spec->splitpath($0);
 105     # $Globals->{'prog'} is `glilypond' when installed,
 106     # `glilypond.pl' when not
 107   }
 108
 109
 110   $\ = "\n";    # adds newline at each print
 111   $/ = "\n";    # newline separates input
 112   $| = 1;       # flush after each print or write command
 113
 114
 115   {
 116     {
 117       # script before run of `make'
 118       my $at = '@';
 119       $Globals->{'before_make'} = TRUE if '@VERSION@' eq "${at}VERSION${at}";
 120     }
 121
 122     my $file_test_pl;
 123     my $glilypond_libdir;
 124
 125     if ( $Globals->{'before_make'} ) { # in source, not yet installed
 126       my $glilypond_dir = $FindBin::Bin;
 127       $glilypond_dir = Cwd::realpath($glilypond_dir);
 128       $glilypond_libdir = $glilypond_dir;
 129
 130     } else {                    # already installed
 131       $Globals->{'groff_version'} = '@VERSION@';
 132       $glilypond_libdir = '@glilypond_dir@';
 133     }
 134
 135     unshift(@INC, $glilypond_libdir);
 136
 137     umask 0077; # octal output: `printf "%03o", umask;'
 138   }
 139
 140   require 'subs.pl';
 141 }
 142
 143 #die "test: ";
 144 ########################################################################
 145 # OOP declarations for some file handles
 146 ########################################################################
 147
 148 require 'oop_fh.pl';
 149
 150 our $stdout = new FH_STDOUT();
 151 our $stderr = new FH_STDERR();
 152
 153 # verbose printing, not clear wether this will be set by `--verbose',
 154 # so store this now into a string, which can be gotten later on, when
 155 # it will become either STDERR or /dev/null
 156 our $v = new FH_STRING();
 157
 158 # for standard output, either STDOUT or output file
 159 our $out;
 160
 161 # end of FH
 162
 163
 164 ########################################################################
 165 # Args: command line arguments
 166 ########################################################################
 167
 168 # command line arguments are handled in 2 runs:
 169 # 1) split short option collections, `=' optargs, and transfer abbrevs
 170 # 2) handle the transferred options with subs
 171
 172 our $Args =
 173   {
 174    'eps_dir' => EMPTYSTRING, # can be overwritten by `--eps_dir'
 175
 176    # `eps-func' has 2 possible values:
 177    # 1) `ly' from `--ly2eps' (default)
 178    # 2) `pdf' `--pdf2eps'
 179    'eps_func' => 'ly',
 180
 181    # files names of temporary files start with this string,
 182    # can be overwritten by `--prefix'
 183    'prefix' => 'ly',
 184
 185    # delete or do not delete temporary files
 186    'keep_all' => FALSE,
 187
 188    # the roff output goes normally to STDOUT, can be a file with `--output'
 189    'output' => EMPTYSTRING,
 190
 191    # temporary directory, can be overwritten by `--temp_dir',
 192    # empty for default of the program
 193    'temp_dir' => EMPTYSTRING,
 194
 195    # regulates verbose output (on STDERR), overwritten by `--verbose'
 196    'verbose' => FALSE,
 197   };
 198
 199 { # `Args'
 200   require 'args.pl';
 201   &run_first();
 202   &install_verbose();
 203   &run_second();
 204   &handle_args();
 205 }
 206
 207 # end `Args'
 208
 209
 210 ########################################################################
 211 # temporary directory .../tmp/groff/USER/lilypond/TIME
 212 ########################################################################
 213
 214 our $Temp =
 215   {
 216    # store the current directory
 217    'cwd' => Cwd::getcwd(),
 218
 219    # directory for EPS files
 220    'eps_dir' => EMPTYSTRING,
 221
 222    # temporary directory
 223    'temp_dir' => EMPTYSTRING,
 224   };
 225
 226 { # `Temp'
 227
 228   if ( $Args->{'temp_dir'} ) {
 229
 230     #----------
 231     # temporary directory was set by `--temp_dir'
 232     #----------
 233
 234     my $dir = $Args->{'temp_dir'};
 235
 236     $dir = &path2abs($dir);
 237     $dir = &make_dir($dir) or
 238       die "The directory `$dir' cannot be used temporarily: $!";
 239
 240
 241     # now `$dir' is a writable directory
 242
 243     opendir( my $dh, $dir ) or
 244       die "Could not open temporary directory `$dir': $!";
 245     my $file_name;
 246     my $found = FALSE;
 247     my $prefix = $Args->{'prefix'};
 248     my $re = qr<
 249                  ^
 250                  $prefix
 251                  _
 252                >x;
 253
 254   READDIR: while ( defined($file_name = readdir($dh)) ) {
 255       chomp $file_name;
 256       if ( $file_name =~ /$re/ ) { # file name starts with $prefix_
 257         $found = TRUE;
 258         last READDIR;
 259       }
 260       next;
 261     }
 262
 263     $Temp->{'temp_dir'} = $dir;
 264     my $n = 0;
 265     while ( $found ) {
 266       $dir = File::Spec->catdir( $Temp->{'temp_dir'}, ++$n );
 267       next if ( -e $dir );
 268
 269       $dir = &make_dir($dir) or next;
 270
 271       $found = FALSE;
 272       last;
 273     }
 274
 275     $Temp->{'temp_dir'} = $dir;
 276
 277
 278   } else { # $Args->{'temp_dir'} not given by `--temp_dir'
 279
 280     #----------
 281     # temporary directory was not set
 282     #----------
 283
 284     { # search for or create a temporary directory
 285
 286       my @tempdirs = EMPTYARRAY;
 287       {
 288         my $tmpdir = File::Spec->tmpdir();
 289         push @tempdirs, $tmpdir if ( $tmpdir && -d $tmpdir && -w $tmpdir );
 290
 291         my $root_dir = File::Spec->rootdir(); # `/' in Unix
 292         my $root_tmp = File::Spec->catdir($root_dir, 'tmp');
 293         push @tempdirs, $root_tmp
 294           if ( $root_tmp ne $tmpdir && -d $root_tmp && -w $root_tmp );
 295
 296         # home directory of the actual user
 297         my $home = File::HomeDir->my_home;
 298         my $home_tmp = File::Spec->catdir($home, 'tmp');
 299         push @tempdirs, $home_tmp if ( -d $home_tmp && -w $home_tmp );
 300
 301         # `/var/tmp' in Unix
 302         my $var_tmp = File::Spec->catdir('', 'var', 'tmp');
 303         push @tempdirs, $var_tmp if ( -d $var_tmp && -w $var_tmp );
 304       }
 305
 306
 307       my @path_extension = qw( groff ); # TEMPDIR/groff/USER/lilypond/<NUMBER>
 308       {
 309         # `$<' is UID of actual user,
 310         # `getpwuid' gets user name in scalar context
 311         my $user = getpwuid($<);
 312         push @path_extension, $user if ( $user );
 313
 314         push @path_extension, qw( lilypond );
 315       }
 316
 317
 318     TEMPS: foreach ( @tempdirs ) {
 319
 320         my $dir; # final directory name in `while' loop
 321         $dir = &path2abs($_);
 322         next TEMPS unless ( $dir );
 323
 324         # beginning of directory name
 325         my @dir_begin =
 326           ( File::Spec->splitdir($dir), @path_extension );
 327
 328
 329         my $n = 0;
 330         my $dir_blocked = TRUE;
 331       BLOCK: while ( $dir_blocked ) {
 332           # should become the final dir name
 333           $dir = File::Spec->catdir(@dir_begin, ++$n);
 334           next BLOCK if ( -d $dir );
 335
 336           # dir name is now free, create it, and end the blocking
 337           my $res = &make_dir( $dir );
 338           die "Could not create directory: $dir" unless ( $res );
 339
 340           $dir = $res;
 341           $dir_blocked = FALSE;
 342         }
 343
 344         next TEMPS unless ( -d $dir && -w $dir  );
 345
 346         # $dir is now a writable directory
 347         $Temp->{'temp_dir'} = $dir; # tmp/groff/USER/lilypond/TIME
 348         last TEMPS;
 349       } # end foreach tmp directories
 350     } # end to create a temporary directory
 351
 352     die "Could not find a temporary directory" unless
 353       ( $Temp->{'temp_dir'} && -d $Temp->{'temp_dir'} &&
 354         -w $Temp->{'temp_dir'} );
 355
 356   } # end temporary directory
 357
 358   $v->print( "Temporary directory: `" . $Temp->{'temp_dir'} . "'\n" );
 359   $v->print( "file_prefix: `" . $Args->{'prefix'} . "'" );
 360
 361
 362   #----------
 363   # EPS directory
 364   #----------
 365
 366   my $make_dir = FALSE;
 367   if ( $Args->{'eps_dir'} ) { # set by `--eps_dir'
 368     my $dir = $Args->{'eps_dir'};
 369
 370     $dir = &path2abs($dir);
 371
 372     if ( -e $dir ) {
 373       goto EMPTY unless ( -w $dir );
 374
 375       # `$dir' is writable
 376       if ( -d $dir ) {
 377         my $upper_dir = $dir;
 378
 379         my $found = FALSE;
 380         opendir( my $dh, $upper_dir ) or $found = TRUE;
 381         my $prefix = $Args->{'prefix'};
 382         my $re = qr<
 383                      ^
 384                      $prefix
 385                      _
 386                    >x;
 387         while ( not $found ) {
 388           my $file_name = readdir($dh);
 389           if ( $file_name =~ /$re/ ) { # file name starts with $prefix_
 390             $found = TRUE;
 391             last;
 392           }
 393           next;
 394         }
 395
 396         my $n = 0;
 397         while ( $found ) {
 398           $dir = File::Spec->catdir($upper_dir, ++$n);
 399           next if ( -d $dir );
 400           $found = FALSE;
 401         }
 402         $make_dir = TRUE;
 403         $Temp->{'eps_dir'} = $dir;
 404       } else { # `$dir' is not a dir, so unlink it to create it as dir
 405         if ( unlink $dir ) { # could remove `$dir'
 406           $Temp->{'eps_dir'} = $dir;
 407           $make_dir = TRUE;
 408         } else { # could not remove
 409           stderr->print(  "Could not use EPS dir `" . $dir .
 410                           "', use temp dir." );
 411         } # end of unlink
 412       } # end test of -d $dir
 413     } else {
 414       $make_dir = TRUE;
 415     } # end of if -e $dir
 416
 417
 418     if ( $make_dir ) { # make directory `$dir'
 419       my $made = FALSE;
 420       $dir = &make_dir($dir) and $made = TRUE;
 421
 422       if ( $made ) {
 423         $Temp->{'eps_dir'} = $dir;
 424         $v->print( "Directory for useful EPS files is `" . $dir . "'." );
 425       } else {
 426         $v->print( "The EPS directory `" . $dir . "' cannot be used: $!" );
 427       }
 428     } else { # `--eps_dir' was not set, so take the temporary directory
 429       $Temp->{'eps_dir'} = $Args->{'temp_dir'};
 430     } # end of make dir
 431   }
 432
 433  EMPTY: unless ( $Temp->{'eps_dir'} ) {
 434     # EPS-dir not set or available, use temp dir,
 435     # but leave $Temp->{'}eps_dir'} empty
 436     $v->print( "Directory for useful EPS files is the " .
 437       "temporary directory `" . $Temp->{'temp_dir'} . "'." );
 438   }
 439
 440 } # end `Temp'
 441
 442
 443 ########################################################################
 444 # Read: read files or stdin
 445 ########################################################################
 446
 447 our $Read =
 448   {
 449    'file_numbered' => EMPTYSTRING,
 450    'file_ly' => EMPTYSTRING, # `$file_numbered.ly'
 451   };
 452
 453 { # read files or stdin
 454
 455   my $ly_number = 0; # number of lilypond file
 456
 457   # `$Args->{'prefix'}_[0-9]'
 458
 459   my $lilypond_mode = FALSE;
 460
 461   my $arg1; # first argument for `.lilypond'
 462   my $arg2; # argument for `.lilypond include'
 463
 464   my $path_ly; # path of ly-file
 465
 466
 467   my $check_file = sub { # for argument of `.lilypond include'
 468     my $file = shift; # argument is a file name
 469     $file = &path2abs($file);
 470     unless ( $file ) {
 471       die "Line `.lilypond include' without argument";
 472       return '';
 473     }
 474     unless ( -f $file && -r $file ) {
 475       die "Argument `$file' in `.lilypond include' is not a readable file";
 476     }
 477
 478     return $file;
 479   }; # end sub &$check_file()
 480
 481
 482   my $increase_ly_number = sub {
 483     ++$ly_number;
 484     $Read->{'file_numbered'} = $Args->{'prefix'} . '_' . $ly_number;
 485     $Read->{'file_ly'} =  $Read->{'file_numbered'} . '.ly';
 486     $path_ly = File::Spec->catdir($Temp->{'temp_dir'}, $Read->{'file_ly'} );
 487   };
 488
 489
 490   my %eps_subs =
 491     (
 492      'ly' => \&create_ly2eps,   # lilypond creates EPS files
 493      'pdf' => \&create_pdf2eps, # lilypond creates PDF file
 494     );
 495
 496   # about lines starting with `.lilypond'
 497
 498   my $ly;
 499   my $fh_include_file;
 500   my %lilypond_args =
 501     (
 502
 503      'start' => sub {
 504        $v->print( "\nline: `.lilypond start'" );
 505        die "Line `.lilypond stop' expected." if ( $lilypond_mode );
 506
 507        $lilypond_mode = TRUE;
 508        &$increase_ly_number;
 509
 510        $v->print( "ly-file: `" . $path_ly . "'" );
 511
 512        $ly = new FH_FILE($path_ly);
 513      },
 514
 515
 516      'end' => sub {
 517        $v->print( "line: `.lilypond end'\n" );
 518        die "Expected line `.lilypond start'." unless ( $lilypond_mode );
 519
 520        $lilypond_mode = FALSE;
 521        $ly->close();
 522
 523        if ( exists $eps_subs{ $Args->{'eps_func'} } ) {
 524          $eps_subs{ $Args->{'eps_func'} }->();
 525        } else {
 526          die "Wrong argument for \%eps_subs: " . $Args->{'eps_func'} . "'";
 527        }
 528      },
 529
 530
 531      'include' => sub { # `.lilypond include file...'
 532
 533        # this may not be used within lilypond mode
 534        next LILYPOND if ( $lilypond_mode );
 535
 536        my $file_arg = shift;
 537
 538        my $file = &$check_file($file_arg);
 539        next LILYPOND unless ( $file );
 540        # file can be read now
 541
 542
 543        # `$fh_write_ly' must be opened
 544        &$increase_ly_number;
 545
 546        $ly = new FH_FILE($path_ly);
 547
 548        my $include = new FH_READ_FILE($file);
 549        my $res = $include->read-all(); # is a refernce to an array
 550        foreach ( @$res ) {
 551          chomp;
 552          $ly->print($_);
 553        }
 554        $ly->close();
 555
 556        if ( exists $eps_subs{ $Args->{'eps_func'} } ) {
 557          $eps_subs{ $Args->{'eps_func'} }->();
 558        } else {
 559          die "Wrong argument for \$eps_subs: `" . $Args->{'eps_func'} . "'";
 560        }
 561      }, # end `.lilypond include'
 562
 563     ); # end definition %lilypond_args
 564
 565
 566  LILYPOND: foreach (<>) {
 567     chomp;
 568     my $line = $_;
 569
 570
 571     # now the lines with '.lilypond ...'
 572
 573     if ( /
 574            ^
 575            [.']
 576            \s*
 577            lilypond
 578            (
 579              .*
 580            )
 581            $
 582          /x ) { # .lilypond ...
 583       my $args = $1;
 584       $args =~ s/
 585                   ^
 586                   \s*
 587                 //x;
 588       $args =~ s/
 589                   \s*
 590                   $
 591                 //x;
 592       $args =~ s/
 593                   ^
 594                   (
 595                     \S*
 596                   )
 597                   \s*
 598                 //x;
 599       my $arg1 = $1; # `start', `end' or `include'
 600       $args =~ s/["'`]//g;
 601       my $arg2 = $args; # file argument for `.lilypond include'
 602
 603       if ( exists $lilypond_args{$arg1} ) {
 604         $lilypond_args{$arg1}->($arg2);
 605         next;
 606       } else {
 607         # not a suitable argument of `.lilypond'
 608         $stderr->print( "Unknown command: `$arg1' `$arg2':  `$line'" );
 609       }
 610
 611       next LILYPOND;
 612     } # end if for .lilypond
 613
 614
 615     if ( $lilypond_mode ) { # do lilypond-mode
 616       # see `.lilypond start'
 617       $ly->print( $line );
 618       next LILYPOND;
 619     } # do lilypond-mode
 620
 621     # unknown line without lilypond
 622     unless ( /
 623                ^
 624                [.']
 625                \s*
 626                lilypond
 627              /x ) { # not a `.lilypond' line
 628       $out->print($line);
 629       next LILYPOND;
 630     }
 631
 632   } # end foreach <>
 633 } # end Read
 634
 635
 636 ########################################################################
 637 # clean up
 638 ########################################################################
 639
 640 END {
 641
 642   exit unless ( defined($Temp->{'temp_dir'}) );
 643
 644   if ( $Args->{'keep_all'} ) {
 645     # With --keep_all, no temporary files are removed.
 646     $v->print( "keep_all: `TRUE'" );
 647     $v->print( "No temporary files will be deleted:" );
 648
 649     opendir my $dh_temp, $Temp->{'temp_dir'} or
 650       die "Cannot open " . $Temp->{'temp_dir'} . ": $!";
 651     for ( sort readdir $dh_temp ) {
 652       next if ( /         # omit files starting with a dot
 653                   ^
 654                   \.
 655                 /x );
 656       if ( /
 657              ^
 658              $Args->{'prefix'}
 659              _
 660            /x ) {
 661         my $file = File::Spec->catfile( $Temp->{'temp_dir'}, $_ );
 662         $v->print( "- " . $file );
 663         next;
 664       }
 665       next;
 666     } # end for sort readdir
 667     closedir $dh_temp;
 668
 669   } else { # keep_all is not set
 670     # Remove all temporary files except the eps files.
 671
 672     $v->print( "keep_all: `FALSE'" );
 673     $v->print( "All temporary files except *.eps will be deleted" );
 674
 675
 676     if ( $Temp->{'eps_dir'} ) {
 677       # EPS files are in another dir, remove temp dir
 678
 679       if ( &is_subdir( $Temp->{'eps_dir'}, $Temp->{'temp_dir'} ) ) {
 680         $v->print( "EPS dir is subdir of temp dir, so keep both." );
 681       } else { # remove temp dir
 682         $v->print( "Try to remove temporary directory `" .
 683           $Temp->{'temp_dir'} ."':" );
 684         if ( File::Path::remove_tree($Temp->{'temp_dir'}) ) {
 685           # remove succeeds
 686           $v->print( "...done." );
 687         } else { # did not remove
 688           $v->print( "Failure to remove temporary directory." );
 689         } # end test on remove
 690       } # end is subdir
 691
 692     } else { # no EPS dir, so keep EPS files
 693
 694       opendir my $dh_temp, $Temp->{'temp_dir'} or
 695         die "Cannot open " . $Temp->{'temp_dir'} . ": $!";
 696       for ( sort readdir $dh_temp ) {
 697         next if ( /          # omit files starting with a dot
 698                     ^
 699                     \.
 700                   /x );
 701         next if ( /          # omit EPS-files
 702                     \.eps
 703                     $
 704                   /x );
 705         if ( /
 706                ^
 707                $Args->{'prefix'}
 708                _
 709              /x ) { # this includes `PREFIX_temp*'
 710           my $file = File::Spec->catfile( $Temp->{'temp_dir'},  $_ );
 711           $v->print( "Remove `" . $file . "'" );
 712           unlink $file or $stderr->print( "Could not remove `$file': $!" );
 713           next;
 714         } # end if prefix
 715         next;
 716       } # end for readdir temp dir
 717       closedir $dh_temp;
 718     } # end if-else EPS files
 719   } # end if-else keep files
 720
 721
 722   if ( $Temp->{'eps_dir'} ) {
 723     # EPS files in $Temp->{'eps_dir'} are always kept
 724     $v->print( "As EPS directrory is set as `" .
 725       $Temp->{'eps_dir'} . "', no EPS files there will be deleted." );
 726
 727     opendir my $dh_temp, $Temp->{'eps_dir'} or
 728       die "Cannot open `" . $Temp->{'eps_dir'} . ": $!";
 729     for ( sort readdir $dh_temp ) {
 730       next if ( /         # omit files starting with a dot
 731                   ^
 732                   \.
 733                 /x );
 734       if ( /
 735              ^
 736              $Args->{'prefix'}
 737              _
 738              .*
 739              \.eps
 740              $
 741            /x ) {
 742         my $file = File::Spec->catfile( $Temp->{'eps_dir'}, $_ );
 743         $v->print( "- " . $file );
 744         next;
 745       } # end if *.eps
 746       next;
 747     } # end for sort readdir
 748     closedir $dh_temp;
 749
 750   }
 751
 752   1;
 753 } # end package Clean
 754
 755
 756 1;
 757 ########################################################################
 758 ### Emacs settings
 759 # Local Variables:
 760 # mode: CPerl
 761 # End: