summaryrefslogtreecommitdiffstats
path: root/contrib/glilypond/glilypond.pl
diff options
context:
space:
mode:
Diffstat (limited to '')
-rwxr-xr-xcontrib/glilypond/glilypond.pl1907
1 files changed, 1907 insertions, 0 deletions
diff --git a/contrib/glilypond/glilypond.pl b/contrib/glilypond/glilypond.pl
new file mode 100755
index 0000000..e97ed24
--- /dev/null
+++ b/contrib/glilypond/glilypond.pl
@@ -0,0 +1,1907 @@
+#! /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:
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 21:58:04 +0000