path: root/contrib/glilypond/glilypond.pl

#! /usr/bin/env perl

package main;

########################################################################
# debugging
########################################################################

# See 'Mastering Perl', chapter 4.

# use strict;
# use warnings;
# use diagnostics;

use Carp;
$SIG{__DIE__} = sub { &Carp::croak; };

use Data::Dumper;

########################################################################
# Legalese
########################################################################

our $Legalese;

{
  use constant VERSION => '1.3.2'; # version of glilypond

### This constant 'LICENSE' is the license for this file 'GPL' >= 3
  use constant LICENSE => q*
glilypond - integrate 'lilypond' into 'groff' files

Copyright (C) 2013-2020 Free Software Foundation, Inc.
  Written by Bernd Warken <groff-bernd.warken-72@web.de>

This file is part of 'GNU groff'.

  'GNU groff' is free software: you can redistribute it and/or modify it
under the terms of the 'GNU General Public License' as published by the
'Free Software Foundation', either version 3 of the License, or (at your
option) any later version.

  'GNU groff' is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 'GNU
General Public License' for more details.

  You should have received a copy of the 'GNU General Public License'
along with 'groff', see the files 'COPYING' and 'LICENSE' in the top
directory of the 'groff' source package.  If not, see
<http://www.gnu.org/licenses/>.
*;


  $Legalese =
    {
     'version' => VERSION,
     'license' => LICENSE,
    }

}

##### end legalese


########################################################################
# global variables and BEGIN
########################################################################

use integer;
use utf8;

use Cwd qw[];
use File::Basename qw[];
use File::Copy qw[];
use File::HomeDir qw[];
use File::Spec qw[];
use File::Path qw[];
use File::Temp qw[];
use FindBin qw[];
use POSIX qw[];


BEGIN {

  use constant FALSE => 0;
  use constant TRUE => 1;
  use constant EMPTYSTRING => '';
  use constant EMPTYARRAY => ();
  use constant EMPTYHASH => ();

  our $Globals =
    {
     'before_make' => FALSE,
     'groff_version' => EMPTYSTRING,
     'prog' => EMPTYSTRING,
    };

  {
    ( my $volume, my $directory, $Globals->{'prog'} ) =
      File::Spec->splitpath($0);
    # $Globals->{'prog'} is 'glilypond' when installed,
    # 'glilypond.pl' when not
  }


  $\ = "\n";	# adds newline at each print
  $/ = "\n";	# newline separates input
  $| = 1;       # flush after each print or write command


  {
    {
      # script before run of 'make'
      my $at = '@';
      $Globals->{'before_make'} = TRUE if '@VERSION@' eq "${at}VERSION${at}";
    }

    my $file_test_pl;
    my $glilypond_libdir;

    if ( $Globals->{'before_make'} ) { # in source, not yet installed
      my $glilypond_dir = $FindBin::Bin;
      $glilypond_dir = Cwd::realpath($glilypond_dir);
      $glilypond_libdir = $glilypond_dir;

    } else {			# already installed
      $Globals->{'groff_version'} = '@VERSION@';
      $glilypond_libdir = '@glilypond_dir@';
    }

    unshift(@INC, $glilypond_libdir);

    umask 0077; # octal output: 'printf "%03o", umask;'
  }

  use integer;
  use utf8;
  use feature 'state';

  my $P_PIC;
  # $P_PIC = '.PDFPIC';
  $P_PIC = '.PSPIC';

  ######################################################################
  # subs for using several times
  ######################################################################

  sub create_ly2eps {		       # '--ly2eps' default
    our ( $out, $Read, $Temp );

    my $prefix = $Read->{'file_numbered'};   # w/ dir change to temp dir

    # '$ lilypond --ps -dbackend=eps -dgs-load-fonts \
    #      output=file_without_extension file.ly'
    # extensions are added automatically
    my $opts = '--ps -dbackend=eps -dinclude-eps-fonts -dgs-load-fonts'
      . " --output=$prefix $prefix";
    &run_lilypond("$opts");

    Cwd::chdir $Temp->{'cwd'} or
	die "Could not change to former directory '" .
	  $Temp->{'cwd'} . "': $!";

    my $eps_dir = $Temp->{'eps_dir'};
    my $dir = $Temp->{'temp_dir'};
    opendir( my $dh, $dir ) or
      die "could not open temporary directory '$dir': $!";

    my $re = qr<
		 ^
		 $prefix
		 -
		 .*
		 \.eps
		 $
	       >x;
    my $file;
    while ( readdir( $dh ) ) {
      chomp;
      $file = $_;
      if ( /$re/ ) {
	my $file_path = File::Spec->catfile($dir, $file);
	if ( $eps_dir ) {
	  my $could_copy = FALSE;
	  File::Copy::copy($file_path, $eps_dir)
	      and $could_copy = TRUE;
	  if ( $could_copy ) {
	    unlink $file_path;
	    $file_path = File::Spec->catfile($eps_dir, $_);
	  }
	}
	$out->print( $P_PIC . ' ' . $file_path );
      }
    }				# end while readdir
    closedir( $dh );
  }				# end sub create_ly2eps()


  sub create_pdf2eps {		       # '--pdf2eps'
    our ( $v, $stdout, $stderr, $out, $Read, $Temp );

    my $prefix = $Read->{'file_numbered'};   # w/ dir change to temp dir

    &run_lilypond("--pdf --output=$prefix $prefix");

    my $file_pdf = $prefix . '.pdf';
    my $file_ps = $prefix . '.ps';

    # pdf2ps in temp dir
    my $temp_file = &next_temp_file;
    $v->print( "\n##### run of 'pdf2ps'" );
    # '$ pdf2ps file.pdf file.ps'
    my $output = `pdf2ps $file_pdf $file_ps 2> $temp_file`;
    die 'Program pdf2ps does not work.' if ( $? );
    &shell_handling($output, $temp_file);
    $v->print( "##### end run of 'pdf2ps'\n" );

    # ps2eps in temp dir
    $temp_file = &next_temp_file;
    $v->print( "\n##### run of 'ps2eps'" );
    # '$ ps2eps file.ps'
    $output = `ps2eps $file_ps 2> $temp_file`;
    die 'Program ps2eps does not work.' if ( $? );
    &shell_handling($output, $temp_file);
    $v->print( "##### end run of 'ps2eps'\n" );

    # change back to former dir
    Cwd::chdir $Temp->{'cwd'} or
	die "Could not change to former directory '" .
	  $Temp->{'cwd'} . "': $!";

    # handling of .eps file
    my $file_eps = $prefix . '.eps';
    my $eps_path = File::Spec->catfile($Temp->{'temp_dir'}, $file_eps);
    if ( $Temp->{'eps_dir'} ) {
      my $has_copied = FALSE;
      File::Copy::copy( $eps_path, $Temp->{'eps_dir'} )
	  and $has_copied = TRUE;
      if ( $has_copied ) {
	unlink $eps_path;
	$eps_path = File::Spec->catfile( $Temp->{'eps_dir'}, $file_eps );
      } else {
	$stderr->print( "Could not use EPS-directory." );
      } # end Temp->{'eps_dir'}
    }
    # print into groff output
    $out->print( $P_PIC . ' ' . $eps_path );
  }				# end sub create_pdf2eps()


  sub is_subdir {		# arg1 is subdir of arg2 (is longer)
    my ( $dir1, $dir2 ) = @_;
    $dir1 = &path2abs( $dir1 );;
    $dir2 = &path2abs( $dir2 );;
    my @split1 = File::Spec->splitdir($dir1);
    my @split2 = File::Spec->splitdir($dir2);
    for ( @split2 ) {
      next if ( $_ eq shift @split1 );
      return FALSE;
    }
    return TRUE;
  }


  sub license {
    our ( $Legalese, $stdout );
    &version;
    $stdout->print( $Legalese->{'license'} );
  } # end sub license()


  sub make_dir {		# make directory or check if it exists
    our ( $v, $Args );

    my $dir_arg = shift;
    chomp $dir_arg;
    $dir_arg =~ s/^\s*(.*)\s*$/$1/;

    unless ( $dir_arg ) {
      $v->print( "make_dir(): empty argument" );
      return FALSE;
    }

    unless ( File::Spec->file_name_is_absolute($dir_arg) ) {
      my $res = Cwd::realpath($dir_arg);
      $res = File::Spec->canonpath($dir_arg) unless ( $res );
      $dir_arg = $res if ( $res );
    }

    return $dir_arg if ( -d $dir_arg && -w $dir_arg );


    # search thru the dir parts
    my @dir_parts = File::Spec->splitdir($dir_arg);
    my @dir_grow;
    my $dir_grow;
    my $can_create = FALSE;	# dir could be created if TRUE

   DIRPARTS: for ( @dir_parts ) {
      push @dir_grow, $_;
      next DIRPARTS unless ( $_ ); # empty string for root directory

      # from array to path dir string
      $dir_grow = File::Spec->catdir(@dir_grow);

      next DIRPARTS if ( -d $dir_grow );

      if ( -e $dir_grow ) {  # exists, but not a dir, so must be removed
	die "Couldn't create dir '$dir_arg', it is blocked by "
	  . "'$dir_grow'." unless ( -w $dir_grow );

	# now it's writable, but not a dir, so it can be removed
	unlink ( $dir_grow ) or
	  die "Couldn't remove '$dir_grow', " .
	    "so I cannot create dir '$dir_arg': $!";
      }

      # $dir_grow no longer exists, so the former dir must be writable
      # in order to create the directory
      pop @dir_grow;
      $dir_grow = File::Spec->catdir(@dir_grow);

      die "'$dir_grow' is not writable, " .
	"so directory '$dir_arg' can't be created."
	  unless ( -w $dir_grow );

      # former directory is writable, so '$dir_arg' can be created

      File::Path::make_path( $dir_arg,
			     {
			      mask => oct('0700'),
			      verbose => $Args->{'verbose'},
			     }
			   )	#  'mkdir -P'
	  or die "Could not create directory '$dir_arg': $!";

      last DIRPARTS;
    }

    die "'$dir_arg' is not a writable directory"
      unless ( -d $dir_arg && -w $dir_arg );

    return $dir_arg;

  } # end sub make_dir()


  my $number = 0;
  sub next_temp_file {
    our ( $Temp, $v, $Args );
    ++$number;
    my $temp_basename = $Args->{'prefix'} . '_temp_' . $number;
    my $temp_file = File::Spec->catfile( $Temp->{'temp_dir'} ,
					 $temp_basename );
    $v->print( "next temporary file: '$temp_file'" );
    return $temp_file;
  }				# end sub next_temp_file()


  sub path2abs {
    our ( $Temp, $Args );

    my $path = shift;
    $path =~ s/
		^
		\s*
		(
		  .*
		)
		\s*
		$
	      /$1/x;

    die "path2abs(): argument is empty." unless ( $path );

    # Perl does not support shell '~' for home dir
    if ( $path =~ /
		    ^
		    ~
		  /x ) {
      if ( $path eq '~' ) {	# only own home
	$path = File::HomeDir->my_home;
      } elsif ( $path =~ m<
			    ^
			    ~ /
			    (
			      .*
			    )
			    $
			  >x ) {	# subdir of own home
	$path = File::Spec->catdir( $Temp->{'cwd'}, $1 );
      } elsif ( $path =~ m<
			    ^
			    ~
			    (
			      [^/]+
			    )
			    $
			  >x ) {	# home of other user
	$path = File::HomeDir->users_home($1);
      } elsif ( $path =~ m<
			    ^
			    ~
			    (
			      [^/]+
			    )
			    /+
			    (
			      .*
			    )
			    $
			  >x ) {	# subdir of other home
	$path = File::Spec->
	  catdir( File::HomeDir->users_home($1), $2 );
      }
    }

    $path = File::Spec->rel2abs($path);

    # now $path is absolute
    return $path;
  } # end sub path2abs()


  sub run_lilypond {
    # arg is the options collection for 'lilypond' to run
    # either from ly or pdf

    our ( $Temp, $v );

    my $opts = shift;
    chomp $opts;

    my $temp_file = &next_temp_file;
    my $output = EMPTYSTRING;

    # change to temp dir
    Cwd::chdir $Temp->{'temp_dir'} or
	die "Could not change to temporary directory '" .
	  $Temp->{'temp_dir'} . "': $!";

    $v->print( "\n##### run of 'lilypond " . $opts . "'" );
    $output = `lilypond $opts 2>$temp_file`;
    die "Program lilypond does not work, see '$temp_file': $?"
      if ( $? );
    chomp $output;
    &shell_handling($output, $temp_file);
    $v->print( "##### end run of 'lilypond'\n" );

    # stay in temp dir
  } # end sub run_lilypond()


  sub shell_handling {
    # Handle ``-shell-command output in a string (arg1).
    # stderr goes to temporary file $TempFile.

    our ( $out, $v, $Args );

    my $out_string = shift;
    my $temp_file = shift;

    my $a = &string2array($out_string); # array ref
    for ( @$a ) {
      $out->print( $_ );
    }

    $temp_file && -f $temp_file && -r $temp_file ||
      die "shell_handling(): $temp_file is not a readable file.";
    my $temp = new FH_READ_FILE($temp_file);
    my $res = $temp->read_all();
    for ( @$res ) {
      chomp;
      $v->print($_);
    }

    unlink $temp_file unless ( $Args->{'keep_all'} );
  } # end sub shell_handling()


  sub string2array {
    my $s = shift;
    my @a = ();
    for ( split "\n", $s ) {
      chomp;
      push @a, $_;
    }
    return \@a;
  } # end string2array()


  sub usage {			# for '--help'
    our ( $Globals, $Args );

    my $p = $Globals->{'prog'};
    my $usage = EMPTYSTRING;
    $usage = '###### usage:' . "\n" if ( $Args->{'verbose'} );
    $usage .= qq*Options for $p:
Read a 'roff' file or standard input and transform 'lilypond' parts
(everything between '.lilypond start' and '.lilypond end') into
'EPS'-files that can be read by groff using '.PSPIC'.

There is also a command '.lilypond include <file_name>' that can
include a complete 'lilypond' file into the 'groff' document.


# Breaking options:
$p -?|-h|--help|--usage    # usage
$p --version               # version information
$p --license               # the license is GPL >= 3


# Normal options:
$p [options] [--] [filename ...]

There are 2 options for influencing the way how the 'EPS' files for the
'roff' display are generated:
--ly2eps           'lilypond' generates 'EPS' files directly (default)
--pdf2eps          'lilypond' generates a 'PDF' file that is transformed

-k|--keep_all      do not delete any temporary files
-v|--verbose       print much information to STDERR

Options with an argument:
-e|--eps_dir=...   use a directory for the EPS files
-o|--output=...    sent output in the groff language into file ...
-p|--prefix=...    start for the names of temporary files
-t|--temp_dir=...  provide the directory for temporary files.

The directories set are created when they do not exist.
*;

    # old options:
    # --keep_files       -k: do not delete any temporary files
    # --file_prefix=...  -p: start for the names of temporary files

    $main::stdout->print( $usage );
  } # end sub usage()


  sub version { # for '--version'
    our ( $Globals, $Legalese, $stdout, $Args );
    my $groff_version = '';
    if ( $Globals->{'groff_version'} ) {
      $groff_version = "(groff $Globals->{'groff_version'}) ";
    }

    my $output = EMPTYSTRING;
    $output = "$Globals->{'prog'} ${groff_version}version "
      .  $Legalese->{'version'};

    $stdout->print($output);
  } # end sub version()
}

#die "test: ";
########################################################################
# OOP declarations for some file handles
########################################################################

use integer;

########################################################################
# OOP for writing file handles that are open by default, like STD*
########################################################################

# -------------------------- _FH_WRITE_OPENED --------------------------

{	# FH_OPENED: base class for all opened file handles, like $TD*

  package _FH_WRITE_OPENED;
  use strict;

  sub new {
    my ( $pkg, $std ) = @_;
    bless {
	   'fh' => $std,
	  }
  }

  sub open {
  }

  sub close {
  }

  sub print {
    my $self = shift;
    for ( @_ ) {
      print { $self->{'fh'} } $_;
    }
  }

}


# ------------------------------ FH_STDOUT ----------------------------

{			     # FH_STDOUT: print to normal output STDOUT

  package FH_STDOUT;
  use strict;
  @FH_STDOUT::ISA = qw( _FH_WRITE_OPENED );

  sub new {
    &_FH_WRITE_OPENED::new( '_FH_WRITE_OPENED', *STDOUT );
  }

}				# end FH_STDOUT


# ------------------------------ FH_STDERR -----------------------------

{				# FH_STDERR: print to STDERR

  package FH_STDERR;
  use strict;
  @FH_STDERR::ISA = qw( _FH_WRITE_OPENED );

  sub new {
    &_FH_WRITE_OPENED::new( 'FH_OPENED', *STDERR );
  }

}				# end FH_STDERR


########################################################################
# OOP for file handles that write into a file or string
########################################################################

# ------------------------------- FH_FILE ------------------------------

{	       # FH_FILE: base class for writing into a file or string

  package FH_FILE;
  use strict;

  sub new {
    my ( $pkg, $file ) = @_;
    bless {
	   'fh' => undef,
	   'file' => $file,
	   'opened' => main::FALSE,
	  }
  }

  sub DESTROY {
    my $self = shift;
    $self->close();
  }

  sub open {
    my $self = shift;
    my $file = $self->{'file'};
    if ( $file && -e $file ) {
      die "file $file is not writable" unless ( -w $file );
      die "$file is a directory" if ( -d $file );
    }
    open $self->{'fh'}, ">", $self->{'file'}
      or die "could not open file '$file' for writing: $!";
    $self->{'opened'} = main::TRUE;
  }

  sub close {
    my $self = shift;
    close $self->{'fh'} if ( $self->{'opened'} );
    $self->{'opened'} = main::FALSE;
  }

  sub print {
    my $self = shift;
    $self->open() unless ( $self->{'opened'} );
    for ( @_ ) {
      print { $self->{'fh'} } $_;
    }
  }

}				# end FH_FILE


# ------------------------------ FH_STRING -----------------------------

{				# FH_STRING: write into a string

  package FH_STRING;		# write to \string
  use strict;
  @FH_STRING::ISA = qw( FH_FILE );

  sub new {
    my $pkg = shift;		# string is a reference to scalar
    bless
      {
       'fh' => undef,
       'string' => '',
       'opened' => main::FALSE,
      }
    }

  sub open {
    my $self = shift;
    open $self->{'fh'}, ">", \ $self->{'string'}
      or die "could not open string for writing: $!";
    $self->{'opened'} = main::TRUE;
  }

  sub get { # get string, move to array ref, close, and return array ref
    my $self = shift;
    return '' unless ( $self->{'opened'} );
    my $a = &string2array( $self->{'string'} );
    $self->close();
    return $a;
  }

}				# end FH_STRING


# -------------------------------- FH_NULL -----------------------------

{				# FH_NULL: write to null device

  package FH_NULL;
  use strict;
  @FH_NULL::ISA = qw( FH_FILE FH_STRING );

  use File::Spec;

  my $devnull = File::Spec->devnull();
  $devnull = '' unless ( -e $devnull && -w $devnull );

  sub new {
    my $pkg = shift;
    if ( $devnull ) {
      &FH_FILE::new( $pkg, $devnull );
    } else {
      &FH_STRING::new( $pkg );
    }
  } # end new()

}				# end FH_NULL


########################################################################
# OOP for reading file handles
########################################################################

# ---------------------------- FH_READ_FILE ----------------------------

{ # FH_READ_FILE: read a file

  package FH_READ_FILE;
  use strict;

  sub new {
    my ( $pkg, $file ) = @_;
    die "File '$file' cannot be read." unless ( -f $file && -r $file );
    bless {
	   'fh' => undef,
	   'file' => $file,
	   'opened' => main::FALSE,
	  }
  }

  sub DESTROY {
    my $self = shift;
    $self->close();
  }

  sub open {
    my $self = shift;
    my $file = $self->{'file'};
    if ( $file && -e $file ) {
      die "file $file is not writable" unless ( -r $file );
      die "$file is a directory" if ( -d $file );
    }
    open $self->{'fh'}, "<", $self->{'file'}
      or die "could not read file '$file': $!";
    $self->{'opened'} = main::TRUE;
  }

  sub close {
    my $self = shift;
    close $self->{'fh'} if ( $self->{'opened'} );
    $self->{'opened'} = main::FALSE;
  }

  sub read_line {
    # Read 1 line of the file into a chomped string.
    # Do not close the read handle at the end.
    my $self = shift;
    $self->open() unless ( $self->{'opened'} );

    my $res;
    if ( defined($res = CORE::readline($self->{'fh'}) ) ) {
      chomp $res;
      return $res;
    } else {
      $self->close();
      return undef;
    }
  }

  sub read_all {
    # Read the complete file into an array reference.
    # Close the read handle at the end.
    # Return array reference.
    my $self = shift;
    $self->open() unless ( $self->{'opened'} );

    my $res = [];
    my $line;
    while ( defined ( $line = CORE::readline $self->{'fh'} ) ) {
      chomp $line;
      push @$res, $line;
    }
    $self->close();
    $self->{'opened'} = main::FALSE;
    return $res;
  }

}

# end of OOP definitions


our $stdout = new FH_STDOUT();
our $stderr = new FH_STDERR();

# verbose printing, not clear whether this will be set by '--verbose',
# so store this now into a string, which can be gotten later on, when
# it will become either STDERR or /dev/null
our $v = new FH_STRING();

# for standard output, either STDOUT or output file
our $out;

# end of FH


########################################################################
# Args: command-line arguments
########################################################################

# command-line arguments are handled in 2 runs:
# 1) split short option collections, '=' optargs, and transfer abbrevs
# 2) handle the transferred options with subs

our $Args =
  {
   'eps_dir' => EMPTYSTRING, # can be overwritten by '--eps_dir'

   # 'eps-func' has 2 possible values:
   # 1) 'pdf' '--pdf2eps' (default)
   # 2) 'ly' from '--ly2eps'
   'eps_func' => 'pdf',

   # files names of temporary files start with this string,
   # can be overwritten by '--prefix'
   'prefix' => 'ly',

   # delete or do not delete temporary files
   'keep_all' => FALSE,

   # the roff output goes normally to STDOUT, can be a file with '--output'
   'output' => EMPTYSTRING,

   # temporary directory, can be overwritten by '--temp_dir',
   # empty for default of the program
   'temp_dir' => EMPTYSTRING,

   # regulates verbose output (on STDERR), overwritten by '--verbose'
   'verbose' => FALSE,
  };

{ # 'Args'
  use integer;

  our ( $Globals, $Args, $stderr, $v, $out );

  # ----------
  # subs for second run, for remaining long options after splitting and
  # transfer
  # ----------

  my %opts_with_arg =
    (

     '--eps_dir' => sub {
       $Args->{'eps_dir'} = shift;
     },

     '--output' => sub {
       $Args->{'output'} = shift;
     },

     '--prefix' => sub {
       $Args->{'prefix'} = shift;
     },

     '--temp_dir' => sub {
       $Args->{'temp_dir'} = shift;
     },

    );				# end of %opts_with_arg


  my %opts_noarg =
    (

     '--help' => sub {
       &usage;
       exit;
     },

     '--keep_all' => sub {
       $Args->{'keep_all'} = TRUE;
     },

     '--license' => sub {
       &license;
       exit;
     },

     '--ly2eps' => sub {
       $Args->{'eps_func'} = 'ly';
     },

     '--pdf2eps' => sub {
       $Args->{'eps_func'} = 'pdf';
     },

     '--verbose' => sub {
       $Args->{'verbose'} = TRUE;
     },

     '--version' => sub {
       &version;
       exit;
     },

    );				# end of %opts_noarg


  # used variables in both runs

  my @files = EMPTYARRAY;


  #----------
  # first run for command-line arguments
  #----------

  # global variables for first run

  my @splitted_args;
  my $double_minus = FALSE;
  my $arg = EMPTYSTRING;
  my $has_arg = FALSE;


  # Split short option collections and transfer these to suitable long
  # options from above.  Note that '-v' now means '--verbose' in version
  # 'v1.1', earlier versions had '--version' for '-v'.

  my %short_opts =
    (
     '?' => '--help',
     'e' => '--eps_dir',
     'h' => '--help',
     'l' => '--license',
     'k' => '--keep_all',
     'o' => '--output',
     'p' => '--prefix',
     't' => '--temp_dir',
     'v' => '--verbose',
     'V' => '--verbose',
    );


  # transfer long option abbreviations to the long options from above

  my @long_opts;

  $long_opts[3] =
    {				# option abbreviations of 3 characters
     '--e' => '--eps_dir',
     '--f' => '--prefix',		# --f for --file_prefix
     '--h' => '--help',
     '--k' => '--keep_all',	# and --keep_files
     '--o' => '--output',
     '--p' => '--prefix',		# and --file_prefix
     '--t' => '--temp_dir',
     '--u' => '--help',		# '--usage' is mapped to '--help'
    };

  $long_opts[4] =
    {				# option abbreviations of 4 characters
     '--li' => '--license',
     '--ly' => '--ly2eps',
     '--pd' => '--pdf2eps',
     '--pr' => '--prefix',
    };

  $long_opts[6] =
    {				# option abbreviations of 6 characters
     '--verb' => '--verbose',
     '--vers' => '--version',
    };


  # subs for short splitting and replacing long abbreviations

  my $split_short = sub {

    my @chars = split //, $1;	# omit leading dash

       # if result is TRUE: run 'next SPLIT' afterwards

     CHARS: while ( @chars ) {
	 my $c = shift @chars;

	 unless ( exists $short_opts{$c} ) {
	   $stderr->print( "Unknown short option '-$c'." );
	   next CHARS;
	 }

	 # short option exists

	 # map or transfer to special long option from above
	 my $transopt = $short_opts{$c};

	 if ( exists $opts_noarg{$transopt} ) {
	   push @splitted_args, $transopt;
	   $Args->{'verbose'}  = TRUE if ( $transopt eq '--verbose' );
	   next CHARS;
	 }

	 if ( exists $opts_with_arg{$transopt} ) {
	   push @splitted_args, $transopt;

	   if ( @chars ) {
	     # if @chars is not empty, option $transopt has argument
	     # in this arg, the rest of characters in @chars
	     push @splitted_args, join "", @chars;
	     @chars = EMPTYARRAY;
	     return TRUE;		# use 'next SPLIT' afterwards
	   }

	   # optarg is the next argument
	   $has_arg = $transopt;
	   return TRUE;		# use 'next SPLIT' afterwards
	 }			# end of if %opts_with_arg
       }				# end of while CHARS
       return FALSE;		# do not do anything
  };				# end of sub for short_opt_collection


  my $split_long = sub {
    my $from_arg = shift;
    $from_arg =~ /^([^=]+)/;
    my $opt_part = lc($1);
    my $optarg = undef;
    if ( $from_arg =~ /=(.*)$/ ) {
      $optarg = $1;
    }

   N: for my $n ( qw/6 4 3/ ) {
      $opt_part =~ / # match $n characters
		     ^
		     (
		       .{$n}
		     )
		   /x;
      my $argn = $1;		# get the first $n characters

      # no match, so luck for fewer number of chars
      next N unless ( $argn );

      next N unless ( exists $long_opts[$n]->{$argn} );
      # not in $n hash, so go on to next loop for $n

      # now $n-hash has arg

      # map or transfer to special long opt from above
      my $transopt = $long_opts[$n]->{$argn};

      # test on option without arg
      if ( exists $opts_noarg{$transopt} ) { # opt has no arg
	$stderr->print( 'Option ' . $transopt . 'has no argument: ' .
			$from_arg . '.' ) if ( defined($optarg) );
	push @splitted_args, $transopt;
	$Args->{'verbose'} = TRUE if ( $transopt eq '--verbose' );
	return TRUE;		# use 'next SPLIT' afterwards
      }				# end of if %opts_noarg

      # test on option with arg
      if ( exists $opts_with_arg{$transopt} ) { # opt has arg
	push @splitted_args, $transopt;

	# test on optarg in arg
	if ( defined($optarg) ) {
	  push @splitted_args, $1;
	  return TRUE; # use 'next SPLIT' afterwards
	} # end of if optarg in arg

	# has optarg in next arg
	$has_arg = $transopt;
	return TRUE; # use 'next SPLIT' afterwards
      } # end of if %opts_with_arg

      # not with and without option, so is not permitted
      $stderr->print( "'" . $transopt .
		      "' is unknown long option from '" . $from_arg . "'" );
      return TRUE; # use 'next SPLIT' afterwards
    } # end of for N
    return FALSE; # do nothing
  }; # end of split_long()


  #----------
  # do split and transfer arguments
  #----------
  sub run_first {

   SPLIT: foreach (@ARGV) {
      # Transform long and short options into some given long options.
      # Split long opts with arg into 2 args (no '=').
      # Transform short option collections into given long options.
      chomp;

      if ( $has_arg ) {
	push @splitted_args, $_;
	$has_arg = EMPTYSTRING;
	next SPLIT;
      }

      if ( $double_minus ) {
	push @files, $_;
	next SPLIT;
      }

      if ( $_ eq '-' ) {		# file arg '-'
	push @files, $_;
	next SPLIT;
      }

      if ( $_ eq '--' ) {		# POSIX arg '--'
	push @splitted_args, $_;
	$double_minus = TRUE;
	next SPLIT;
      }

      if ( / # short option or collection of short options
	     ^
	     -
	     (
	       [^-]
	       .*
	     )
	     $
	   /x ) {
	$split_short->($1);
	next SPLIT;
      }				# end of short option

      if ( /^--/ ) {		# starts with 2 dashes, a long option
	$split_long->($_);
	next SPLIT;
      }				# end of long option

      # unknown option without leading dash is a file name
      push @files, $_;
      next SPLIT;
    }				# end of foreach SPLIT

				  # all args are considered
    $stderr->print( "Option '$has_arg' needs an argument." )
      if ( $has_arg );


    push @files, '-' unless ( @files );
    @ARGV = @splitted_args;

  };		    # end of first run, splitting with map or transfer


  #----------
  # open or ignore verbose output
  #----------
  sub install_verbose {
    if ( $Args->{'verbose'} ) { # '--verbose' was used
      # make verbose output into $v
      # get content of string so far as array ref, close
      my $s = $v->get();

      $v = new FH_STDERR(); # make verbose output into STDERR
      if ( $s ) {
	for ( @$s ) {
	  # print the file content into new verbose output
	  $v->print($_);
	}
      }
      # verbose output is now active (into STDERR)
      $v->print( "Option '-v' means '--verbose'." );
      $v->print( "Version information is printed by option"
	         . " '--version'."
      );
      $v->print( "#" x 72 );

    } else { # '--verbose' was not used
      # do not be verbose, make verbose invisible

      $v->close(); # close and ignore the string content

      $v = new FH_NULL();
      # this is either into /dev/null or in an ignored string

    } # end if-else about verbose
    # '$v->print' works now in any case

    $v->print( "Verbose output was chosen." );

    my $s = $Globals->{'prog_is_installed'} ? '' : ' not';
    $v->print( $Globals->{'prog'} . " is" . $s .
	       " installed." );

    $v->print( 'The command-line options are:' );

    $s = "  options:";
    $s .= " '" . $_ . "'" for ( @ARGV );
    $v->print( $s );

    $s = "  file names:";
    $s .= " '" . $_ . "'\n" for ( @files );
    $v->print( $s );
  } # end install_verbose()


  #----------
  # second run of command-line arguments
  #----------
  sub run_second {
      # Second run of args with new @ARGV from the former splitting.
      # Arguments are now split and transformed into special long
      # options.

      my $double_minus = FALSE;
      my $has_arg = FALSE;

    ARGS: for my $arg ( @ARGV ) {

	# ignore '--', file names are handled later on
	last ARGS if ( $arg eq '--' );

	if ( $has_arg ) {
	  unless ( exists $opts_with_arg{$has_arg} ) {
	    $stderr->print( "'\%opts_with_args' does not have key '" .
			      $has_arg . "'." );
	    next ARGS;
	  }

	  $opts_with_arg{$has_arg}->($arg);
	  $has_arg = FALSE;
	  next ARGS;
	} # end of $has_arg

	if ( exists $opts_with_arg{$arg} ) {
	  $has_arg = $arg;
	  next ARGS;
	}

	if ( exists $opts_noarg{$arg} ) {
	  $opts_noarg{$arg}->();
	  next ARGS;
	}

	# not a suitable option
	$stderr->print( "Wrong option '" . $arg . "'." );
	next ARGS;

      } # end of for ARGS:


      if ( $has_arg ) { # after last argument
	die "Option '$has_arg' needs an argument.";
      }

    }; # end of second run


  sub handle_args {
    # handling the output of args

    if ( $Args->{'output'} ) { # '--output' was set in the arguments
      my $out_path = &path2abs($Args->{'output'});
      die "Output file name $Args->{'output'} cannot be used."
	unless ( $out_path );

      my ( $file, $dir );
      ( $file, $dir ) = File::Basename::fileparse($out_path)
	or die "Could not handle output file path '" . $out_path
	  . "': directory name '" . $dir . "' and file name '" . $file
	  . "'.";

      die "Could not find output directory for '" . $Args->{'output'}
        . "'" unless ( $dir );
      die "Could not find output file: '" . $Args->{'output'} .
	"'" unless ( $file );

      if ( -d $dir ) {
	die "Could not write to output directory '" . $dir . "'."
	  unless ( -w $dir );
      } else {
	$dir = &make_dir($dir);
	die "Could not create output directory in: '" . $out_path . "'."
	  unless ( $dir );
      }

      # now $dir is a writable directory

      if ( -e $out_path ) {
	die "Could not write to output file '" . $out_path . "'."
	  unless ( -w $out_path );
      }

      $out = new FH_FILE( $out_path );
      $v->print( "Output goes to file '" . $out_path . "'." );
    } else { # '--output' was not set
      $out = new FH_STDOUT();
    }
    # no $out is the right behavior for standard output

  #  $Args->{'prefix'} .= '_' . $Args->{'eps_func'} . '2eps';

    @ARGV = @files;
  }

  &run_first();
  &install_verbose();
  &run_second();
  &handle_args();
}

# end 'Args'


########################################################################
# temporary directory .../tmp/groff/USER/lilypond/TIME
########################################################################

our $Temp =
  {
   # store the current directory
   'cwd' => Cwd::getcwd(),

   # directory for EPS files
   'eps_dir' => EMPTYSTRING,

   # temporary directory
   'temp_dir' => EMPTYSTRING,
  };

{ # 'Temp'

  if ( $Args->{'temp_dir'} ) {

    #----------
    # temporary directory was set by '--temp_dir'
    #----------

    my $dir = $Args->{'temp_dir'};

    $dir = &path2abs($dir);
    $dir = &make_dir($dir) or
      die "The directory '$dir' cannot be used temporarily: $!";


    # now '$dir' is a writable directory

    opendir( my $dh, $dir ) or
      die "Could not open temporary directory '$dir': $!";
    my $file_name;
    my $found = FALSE;
    my $prefix = $Args->{'prefix'};
    my $re = qr<
		 ^
		 $prefix
		 _
	       >x;

  READDIR: while ( defined($file_name = readdir($dh)) ) {
      chomp $file_name;
      if ( $file_name =~ /$re/ ) { # file name starts with $prefix_
	$found = TRUE;
	last READDIR;
      }
      next;
    }

    $Temp->{'temp_dir'} = $dir;
    my $n = 0;
    while ( $found ) {
      $dir = File::Spec->catdir( $Temp->{'temp_dir'}, ++$n );
      next if ( -e $dir );

      $dir = &make_dir($dir) or next;

      $found = FALSE;
      last;
    }

    $Temp->{'temp_dir'} = $dir;


  } else { # $Args->{'temp_dir'} not given by '--temp_dir'

    #----------
    # temporary directory was not set
    #----------

    { # search for or create a temporary directory

      my @tempdirs = EMPTYARRAY;
      {
	my $tmpdir = File::Spec->tmpdir();
	push @tempdirs, $tmpdir
	  if ( $tmpdir && -d $tmpdir && -w $tmpdir );

	my $root_dir = File::Spec->rootdir(); # '/' in Unix
	my $root_tmp = File::Spec->catdir($root_dir, 'tmp');
	push @tempdirs, $root_tmp
	  if ( $root_tmp ne $tmpdir && -d $root_tmp && -w $root_tmp );

	# home directory of the actual user
	my $home = File::HomeDir->my_home;
	my $home_tmp = File::Spec->catdir($home, 'tmp');
	push @tempdirs, $home_tmp if ( -d $home_tmp && -w $home_tmp );

	# '/var/tmp' in Unix
	my $var_tmp = File::Spec->catdir('', 'var', 'tmp');
	push @tempdirs, $var_tmp if ( -d $var_tmp && -w $var_tmp );
      }


      my @path_extension = qw( groff ); # TEMPDIR/groff/USER/lilypond/N
      {
	# '$<' is UID of actual user,
	# 'getpwuid' gets user name in scalar context
	my $user = getpwuid($<);
	push @path_extension, $user if ( $user );

	push @path_extension, qw( lilypond );
      }


    TEMPS: foreach ( @tempdirs ) {

	my $dir; # final directory name in 'while' loop
	$dir = &path2abs($_);
	next TEMPS unless ( $dir );

	# beginning of directory name
	my @dir_begin =
	  ( File::Spec->splitdir($dir), @path_extension );


	my $n = 0;
	my $dir_blocked = TRUE;
      BLOCK: while ( $dir_blocked ) {
	  # should become the final dir name
	  $dir = File::Spec->catdir(@dir_begin, ++$n);
	  next BLOCK if ( -d $dir );

	  # dir name is now free, create it, and end the blocking
	  my $res = &make_dir( $dir );
	  die "Could not create directory: $dir" unless ( $res );

	  $dir = $res;
	  $dir_blocked = FALSE;
	}

	next TEMPS unless ( -d $dir && -w $dir  );

	# $dir is now a writable directory
	$Temp->{'temp_dir'} = $dir; # tmp/groff/USER/lilypond/TIME
	last TEMPS;
      } # end foreach tmp directories
    } # end to create a temporary directory

    die "Could not find a temporary directory" unless
      ( $Temp->{'temp_dir'} && -d $Temp->{'temp_dir'} &&
	-w $Temp->{'temp_dir'} );

  } # end temporary directory

  $v->print( "Temporary directory: '" . $Temp->{'temp_dir'} . "'\n" );
  $v->print( "file_prefix: '" . $Args->{'prefix'} . "'" );


  #----------
  # EPS directory
  #----------

  my $make_dir = FALSE;
  if ( $Args->{'eps_dir'} ) { # set by '--eps_dir'
    my $dir = $Args->{'eps_dir'};

    $dir = &path2abs($dir);

    if ( -e $dir ) {
      goto EMPTY unless ( -w $dir );

      # '$dir' is writable
      if ( -d $dir ) {
	my $upper_dir = $dir;

	my $found = FALSE;
	opendir( my $dh, $upper_dir ) or $found = TRUE;
	my $prefix = $Args->{'prefix'};
	my $re = qr<
		     ^
		     $prefix
		     _
		   >x;
	while ( not $found ) {
	  my $file_name = readdir($dh);
	  if ( $file_name =~ /$re/ ) { # file name starts with $prefix_
	    $found = TRUE;
	    last;
	  }
	  next;
	}

	my $n = 0;
	while ( $found ) {
	  $dir = File::Spec->catdir($upper_dir, ++$n);
	  next if ( -d $dir );
	  $found = FALSE;
	}
	$make_dir = TRUE;
	$Temp->{'eps_dir'} = $dir;
      } else { # '$dir' is not a dir, so unlink it to create it as dir
	if ( unlink $dir ) { # could remove '$dir'
	  $Temp->{'eps_dir'} = $dir;
	  $make_dir = TRUE;
	} else { # could not remove
	  $stderr->print( "Could not use EPS dir '" . $dir .
			  "', use temp dir." );
	} # end of unlink
      } # end test of -d $dir
    } else {
      $make_dir = TRUE;
    } # end of if -e $dir


    if ( $make_dir ) { # make directory '$dir'
      my $made = FALSE;
      $dir = &make_dir($dir) and $made = TRUE;

      if ( $made ) {
	$Temp->{'eps_dir'} = $dir;
	$v->print( "Directory for useful EPS files is '" . $dir . "'." );
      } else {
	$v->print( "The EPS directory '" . $dir . "' cannot be used: $!" );
      }
    } else { # '--eps_dir' was not set, so take the temporary directory
      $Temp->{'eps_dir'} = $Args->{'temp_dir'};
    } # end of make dir
  }

 EMPTY: unless ( $Temp->{'eps_dir'} ) {
    # EPS-dir not set or available, use temp dir,
    # but leave $Temp->{'}eps_dir'} empty
    $v->print( "Directory for useful EPS files is the " .
      "temporary directory '" . $Temp->{'temp_dir'} . "'." );
  }

} # end 'Temp'


########################################################################
# Read: read files or stdin
########################################################################

our $Read =
  {
   'file_numbered' => EMPTYSTRING,
   'file_ly' => EMPTYSTRING, # '$file_numbered.ly'
  };

{ # read files or stdin

  my $ly_number = 0; # number of lilypond file

  # '$Args->{'prefix'}_[0-9]'

  my $lilypond_mode = FALSE;

  my $arg1; # first argument for '.lilypond'
  my $arg2; # argument for '.lilypond include'

  my $path_ly; # path of ly-file


  my $check_file = sub { # for argument of '.lilypond include'
    my $file = shift; # argument is a file name
    $file = &path2abs($file);
    unless ( $file ) {
      die "Line '.lilypond include' without argument";
      return '';
    }
    unless ( -f $file && -r $file ) {
      die "Argument '$file' in '.lilypond include' is not a readable file";
    }

    return $file;
  }; # end sub &$check_file()


  my $increase_ly_number = sub {
    ++$ly_number;
    $Read->{'file_numbered'} = $Args->{'prefix'} . '_' . $ly_number;
    $Read->{'file_ly'} =  $Read->{'file_numbered'} . '.ly';
    $path_ly = File::Spec->catdir($Temp->{'temp_dir'}, $Read->{'file_ly'} );
  };


  my %eps_subs =
    (
     'ly' => \&create_ly2eps,   # lilypond creates EPS files
     'pdf' => \&create_pdf2eps, # lilypond creates PDF file
    );

  # about lines starting with '.lilypond'

  my $ly;
  my $fh_include_file;
  my %lilypond_args =
    (

     'start' => sub {
       $v->print( "\nline: '.lilypond start'" );
       die "Line '.lilypond stop' expected." if ( $lilypond_mode );

       $lilypond_mode = TRUE;
       &$increase_ly_number;

       $v->print( "ly-file: '" . $path_ly . "'" );

       $ly = new FH_FILE($path_ly);
     },


     'end' => sub {
       $v->print( "line: '.lilypond end'\n" );
       die "Expected line '.lilypond start'." unless ( $lilypond_mode );

       $lilypond_mode = FALSE;
       $ly->close();

       if ( exists $eps_subs{ $Args->{'eps_func'} } ) {
	 $eps_subs{ $Args->{'eps_func'} }->();
       } else {
	 die "Wrong argument for \%eps_subs: " . $Args->{'eps_func'} . "'";
       }
     },


     'include' => sub { # '.lilypond include file...'

       # this may not be used within lilypond mode
       next LILYPOND if ( $lilypond_mode );

       my $file_arg = shift;

       my $file = &$check_file($file_arg);
       next LILYPOND unless ( $file );
       # file can be read now


       # '$fh_write_ly' must be opened
       &$increase_ly_number;

       $ly = new FH_FILE($path_ly);

       my $include = new FH_READ_FILE($file);
       my $res = $include->read_all(); # is a reference to an array
       foreach ( @$res ) {
	 chomp;
	 $ly->print($_);
       }
       $ly->close();

       if ( exists $eps_subs{ $Args->{'eps_func'} } ) {
	 $eps_subs{ $Args->{'eps_func'} }->();
       } else {
	 die "Wrong argument for \$eps_subs: '" . $Args->{'eps_func'} . "'";
       }
     }, # end '.lilypond include'

    ); # end definition %lilypond_args


 LILYPOND: foreach my $filename (@ARGV) {
    my $input;
    if ($filename eq '-') {
      $input = \*STDIN;
    } elsif (not open $input, '<', $filename) {
      warn $!;
      next;
    }
    while (<$input>) {
      chomp;
      my $line = $_;


      # now the lines with '.lilypond ...'

      if ( /
	     ^
	     [.']
	     \s*
	     lilypond
	     (
	       .*
	     )
	     $
	   /x ) { # .lilypond ...
	my $args = $1;
	$args =~ s/
		    ^
		    \s*
		  //x;
	$args =~ s/
		    \s*
		    $
		  //x;
	$args =~ s/
		    ^
		    (
		      \S*
		    )
		    \s*
		  //x;
	my $arg1 = $1; # 'start', 'end' or 'include'
	$args =~ s/["'`]//g;
	my $arg2 = $args; # file argument for '.lilypond include'

	if ( exists $lilypond_args{$arg1} ) {
	  $lilypond_args{$arg1}->($arg2);
	  next;
	} else {
	  # not a suitable argument of '.lilypond'
	  $stderr->print( "Unknown command: '$arg1' '$arg2':  '$line'" );
	}

	next LILYPOND;
      } # end if for .lilypond


      if ( $lilypond_mode ) { # do lilypond-mode
	# see '.lilypond start'
	$ly->print( $line );
	next LILYPOND;
      } # do lilypond-mode

      # unknown line without lilypond
      unless ( /
		 ^
		 [.']
		 \s*
		 lilypond
	       /x ) { # not a '.lilypond' line
	$out->print($line);
	next LILYPOND;
      }
    } # end while <$input>
  } # end foreach $filename
} # end Read


########################################################################
# clean up
########################################################################

END {

  exit unless ( defined($Temp->{'temp_dir'}) );

  if ( $Args->{'keep_all'} ) {
    # With --keep_all, no temporary files are removed.
    $v->print( "keep_all: 'TRUE'" );
    $v->print( "No temporary files will be deleted:" );

    opendir my $dh_temp, $Temp->{'temp_dir'} or
      die "Cannot open " . $Temp->{'temp_dir'} . ": $!";
    for ( sort readdir $dh_temp ) {
      next if ( /         # omit files starting with a dot
		  ^
		  \.
		/x );
      if ( /
	     ^
	     $Args->{'prefix'}
	     _
	   /x ) {
	my $file = File::Spec->catfile( $Temp->{'temp_dir'}, $_ );
	$v->print( "- " . $file );
	next;
      }
      next;
    } # end for sort readdir
    closedir $dh_temp;

  } else { # keep_all is not set
    # Remove all temporary files except the eps files.

    $v->print( "keep_all: 'FALSE'" );
    $v->print( "All temporary files except *.eps will be deleted" );


    if ( $Temp->{'eps_dir'} ) {
      # EPS files are in another dir, remove temp dir

      if ( &is_subdir( $Temp->{'eps_dir'}, $Temp->{'temp_dir'} ) ) {
	$v->print( "EPS dir is subdir of temp dir, so keep both." );
      } else { # remove temp dir
	$v->print( "Try to remove temporary directory '" .
	  $Temp->{'temp_dir'} ."':" );
	if ( File::Path::remove_tree($Temp->{'temp_dir'}) ) {
	  # remove succeeds
	  $v->print( "...done." );
	} else { # did not remove
	  $v->print( "Failure to remove temporary directory." );
	} # end test on remove
      } # end is subdir

    } else { # no EPS dir, so keep EPS files

      opendir my $dh_temp, $Temp->{'temp_dir'} or
	die "Cannot open " . $Temp->{'temp_dir'} . ": $!";
      for ( sort readdir $dh_temp ) {
	next if ( /          # omit files starting with a dot
		    ^
		    \.
		  /x );
	next if ( /          # omit EPS-files
		    \.eps
		    $
		  /x );
	if ( /
	       ^
	       $Args->{'prefix'}
	       _
	     /x ) { # this includes 'PREFIX_temp*'
	  my $file = File::Spec->catfile( $Temp->{'temp_dir'},  $_ );
	  $v->print( "Remove '" . $file . "'" );
	  unlink $file or $stderr->print( "Could not remove '$file': $!" );
	  next;
	} # end if prefix
	next;
      } # end for readdir temp dir
      closedir $dh_temp;
    } # end if-else EPS files
  } # end if-else keep files


  if ( $Temp->{'eps_dir'} ) {
    # EPS files in $Temp->{'eps_dir'} are always kept
    $v->print( "As EPS directory is set as '" .
      $Temp->{'eps_dir'} . "', no EPS files there will be deleted." );

    opendir my $dh_temp, $Temp->{'eps_dir'} or
      die "Cannot open '" . $Temp->{'eps_dir'} . ": $!";
    for ( sort readdir $dh_temp ) {
      next if ( /         # omit files starting with a dot
		  ^
		  \.
		/x );
      if ( /
	     ^
	     $Args->{'prefix'}
	     _
	     .*
	     \.eps
	     $
	   /x ) {
	my $file = File::Spec->catfile( $Temp->{'eps_dir'}, $_ );
	$v->print( "- " . $file );
	next;
      } # end if *.eps
      next;
    } # end for sort readdir
    closedir $dh_temp;

  }

  1;
} # end package Clean


1;
# Local Variables:
# fill-column: 72
# mode: CPerl
# End:
# vim: set autoindent textwidth=72: