1my $License = q* 2######################################################################## 3# Legalese 4######################################################################## 5 6Subroutines for 'glilypond'. 7 8Source file position: '<groff-source>/contrib/glilypond/subs.pl' 9Installed position: '<prefix>/lib/groff/glilypond/subs.pl' 10 11Copyright (C) 2013-2018 Free Software Foundation, Inc. 12 Written by Bernd Warken <groff-bernd.warken-72@web.de> 13 14Last update: 10 Sep 2015 15 16This file is part of 'glilypond', which is part of 'GNU groff'. 17 18 'GNU groff' is free software: you can redistribute it and/or modify it 19under the terms of the 'GNU General Public License' as published by the 20'Free Software Foundation', either version 3 of the License, or (at your 21option) any later version. 22 23 'GNU groff' is distributed in the hope that it will be useful, but 24WITHOUT ANY WARRANTY; without even the implied warranty of 25MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 'GNU 26General Public License' for more details. 27 28 You should have received a copy of the 'GNU General Public License' 29along with 'groff', see the files 'COPYING' and 'LICENSE' in the top 30directory of the 'groff' source package. If not, see 31<http://www.gnu.org/licenses/>. 32*; 33 34##### end legalese 35 36 37# use strict; 38# use warnings; 39# use diagnostics; 40 41use integer; 42use utf8; 43use feature 'state'; 44 45my $P_PIC; 46# $P_PIC = '.PDFPIC'; 47$P_PIC = '.PSPIC'; 48 49######################################################################## 50# subs for using several times 51######################################################################## 52 53sub create_ly2eps { # '--ly2eps' default 54 our ( $out, $Read, $Temp ); 55 56 my $prefix = $Read->{'file_numbered'}; # with dir change to temp dir 57 58 # '$ lilypond --ps -dbackend=eps -dgs-load-fonts \ 59 # output=file_without_extension file.ly' 60 # extensions are added automatically 61 my $opts = '--ps -dbackend=eps -dinclude-eps-fonts -dgs-load-fonts ' . 62 "--output=$prefix $prefix"; 63 &run_lilypond("$opts"); 64 65 Cwd::chdir $Temp->{'cwd'} or 66 die "Could not change to former directory '" . 67 $Temp->{'cwd'} . "': $!"; 68 69 my $eps_dir = $Temp->{'eps_dir'}; 70 my $dir = $Temp->{'temp_dir'}; 71 opendir( my $dh, $dir ) or 72 die "could not open temporary directory '$dir': $!"; 73 74 my $re = qr< 75 ^ 76 $prefix 77 - 78 .* 79 \.eps 80 $ 81 >x; 82 my $file; 83 while ( readdir( $dh ) ) { 84 chomp; 85 $file = $_; 86 if ( /$re/ ) { 87 my $file_path = File::Spec->catfile($dir, $file); 88 if ( $eps_dir ) { 89 my $could_copy = FALSE; 90 File::Copy::copy($file_path, $eps_dir) 91 and $could_copy = TRUE; 92 if ( $could_copy ) { 93 unlink $file_path; 94 $file_path = File::Spec->catfile($eps_dir, $_); 95 } 96 } 97 $out->print( $P_PIC . ' ' . $file_path ); 98 } 99 } # end while readdir 100 closedir( $dh ); 101} # end sub create_ly2eps() 102 103 104sub create_pdf2eps { # '--pdf2eps' 105 our ( $v, $stdout, $stderr, $out, $Read, $Temp ); 106 107 my $prefix = $Read->{'file_numbered'}; # with dir change to temp dir 108 109 &run_lilypond("--pdf --output=$prefix $prefix"); 110 111 my $file_pdf = $prefix . '.pdf'; 112 my $file_ps = $prefix . '.ps'; 113 114 # pdf2ps in temp dir 115 my $temp_file = &next_temp_file; 116 $v->print( "\n##### run of 'pdf2ps'" ); 117 # '$ pdf2ps file.pdf file.ps' 118 my $output = `pdf2ps $file_pdf $file_ps 2> $temp_file`; 119 die 'Program pdf2ps does not work.' if ( $? ); 120 &shell_handling($output, $temp_file); 121 $v->print( "##### end run of 'pdf2ps'\n" ); 122 123 # ps2eps in temp dir 124 $temp_file = &next_temp_file; 125 $v->print( "\n##### run of 'ps2eps'" ); 126 # '$ ps2eps file.ps' 127 $output = `ps2eps $file_ps 2> $temp_file`; 128 die 'Program ps2eps does not work.' if ( $? ); 129 &shell_handling($output, $temp_file); 130 $v->print( "##### end run of 'ps2eps'\n" ); 131 132 # change back to former dir 133 Cwd::chdir $Temp->{'cwd'} or 134 die "Could not change to former directory '" . 135 $Temp->{'cwd'} . "': $!"; 136 137 # handling of .eps file 138 my $file_eps = $prefix . '.eps'; 139 my $eps_path = File::Spec->catfile($Temp->{'temp_dir'}, $file_eps); 140 if ( $Temp->{'eps_dir'} ) { 141 my $has_copied = FALSE; 142 File::Copy::copy( $eps_path, $Temp->{'eps_dir'} ) 143 and $has_copied = TRUE; 144 if ( $has_copied ) { 145 unlink $eps_path; 146 $eps_path = File::Spec->catfile( $Temp->{'eps_dir'}, $file_eps ); 147 } else { 148 $stderr->print( "Could not use EPS-directory." ); 149 } # end Temp->{'eps_dir'} 150 } 151 # print into groff output 152 $out->print( $P_PIC . ' ' . $eps_path ); 153} # end sub create_pdf2eps() 154 155 156sub is_subdir { # arg1 is subdir of arg2 (is longer) 157 my ( $dir1, $dir2 ) = @_; 158 $dir1 = &path2abs( $dir1 );; 159 $dir2 = &path2abs( $dir2 );; 160 my @split1 = File::Spec->splitdir($dir1); 161 my @split2 = File::Spec->splitdir($dir2); 162 for ( @split2 ) { 163 next if ( $_ eq shift @split1 ); 164 return FALSE; 165 } 166 return TRUE; 167} 168 169 170sub license { 171 our ( $Legalese, $stdout ); 172 &version; 173 $stdout->print( $Legalese->{'license'} ); 174} # end sub license() 175 176 177sub make_dir { # make directory or check if it exists 178 our ( $v, $Args ); 179 180 my $dir_arg = shift; 181 chomp $dir_arg; 182 $dir_arg =~ s/^\s*(.*)\s*$/$1/; 183 184 unless ( $dir_arg ) { 185 $v->print( "make_dir(): empty argument" ); 186 return FALSE; 187 } 188 189 unless ( File::Spec->file_name_is_absolute($dir_arg) ) { 190 my $res = Cwd::realpath($dir_arg); 191 $res = File::Spec->canonpath($dir_arg) unless ( $res ); 192 $dir_arg = $res if ( $res ); 193 } 194 195 return $dir_arg if ( -d $dir_arg && -w $dir_arg ); 196 197 198 # search thru the dir parts 199 my @dir_parts = File::Spec->splitdir($dir_arg); 200 my @dir_grow; 201 my $dir_grow; 202 my $can_create = FALSE; # dir could be created if TRUE 203 204 DIRPARTS: for ( @dir_parts ) { 205 push @dir_grow, $_; 206 next DIRPARTS unless ( $_ ); # empty string for root directory 207 208 # from array to path dir string 209 $dir_grow = File::Spec->catdir(@dir_grow); 210 211 next DIRPARTS if ( -d $dir_grow ); 212 213 if ( -e $dir_grow ) { # exists, but not a dir, so must be removed 214 die "Couldn't create dir '$dir_arg', it is blocked by '$dir_grow'." 215 unless ( -w $dir_grow ); 216 217 # now it's writable, but not a dir, so it can be removed 218 unlink ( $dir_grow ) or 219 die "Couldn't remove '$dir_grow', " . 220 "so I cannot create dir '$dir_arg': $!"; 221 } 222 223 # $dir_grow does no longer exist, so the former dir must be writable 224 # in order to create the directory 225 pop @dir_grow; 226 $dir_grow = File::Spec->catdir(@dir_grow); 227 228 die "'$dir_grow' is not writable, " . 229 "so directory '$dir_arg' can't be createdd." 230 unless ( -w $dir_grow ); 231 232 # former directory is writable, so '$dir_arg' can be created 233 234 File::Path::make_path( $dir_arg, 235 { 236 mask => oct('0700'), 237 verbose => $Args->{'verbose'}, 238 } 239 ) # 'mkdir -P' 240 or die "Could not create directory '$dir_arg': $!"; 241 242 last DIRPARTS; 243 } 244 245 die "'$dir_arg' is not a writable directory" 246 unless ( -d $dir_arg && -w $dir_arg ); 247 248 return $dir_arg; 249 250} # end sub make_dir() 251 252 253my $number = 0; 254sub next_temp_file { 255 our ( $Temp, $v, $Args ); 256 ++$number; 257 my $temp_basename = $Args->{'prefix'} . '_temp_' . $number; 258 my $temp_file = File::Spec->catfile( $Temp->{'temp_dir'} , 259 $temp_basename ); 260 $v->print( "next temporary file: '$temp_file'" ); 261 return $temp_file; 262} # end sub next_temp_file() 263 264 265sub path2abs { 266 our ( $Temp, $Args ); 267 268 my $path = shift; 269 $path =~ s/ 270 ^ 271 \s* 272 ( 273 .* 274 ) 275 \s* 276 $ 277 /$1/x; 278 279 die "path2abs(): argument is empty." unless ( $path ); 280 281 # Perl does not support shell '~' for home dir 282 if ( $path =~ / 283 ^ 284 ~ 285 /x ) { 286 if ( $path eq '~' ) { # only own home 287 $path = File::HomeDir->my_home; 288 } elsif ( $path =~ m< 289 ^ 290 ~ / 291 ( 292 .* 293 ) 294 $ 295 >x ) { # subdir of own home 296 $path = File::Spec->catdir( $Temp->{'cwd'}, $1 ); 297 } elsif ( $path =~ m< 298 ^ 299 ~ 300 ( 301 [^/]+ 302 ) 303 $ 304 >x ) { # home of other user 305 $path = File::HomeDir->users_home($1); 306 } elsif ( $path =~ m< 307 ^ 308 ~ 309 ( 310 [^/]+ 311 ) 312 /+ 313 ( 314 .* 315 ) 316 $ 317 >x ) { # subdir of other home 318 $path = File::Spec-> 319 catdir( File::HomeDir->users_home($1), $2 ); 320 } 321 } 322 323 $path = File::Spec->rel2abs($path); 324 325 # now $path is absolute 326 return $path; 327} # end sub path2abs() 328 329 330sub run_lilypond { 331 # arg is the options collection for 'lilypond' to run 332 # either from ly or pdf 333 334 our ( $Temp, $v ); 335 336 my $opts = shift; 337 chomp $opts; 338 339 my $temp_file = &next_temp_file; 340 my $output = EMPTYSTRING; 341 342 # change to temp dir 343 Cwd::chdir $Temp->{'temp_dir'} or 344 die "Could not change to temporary directory '" . 345 $Temp->{'temp_dir'} . "': $!"; 346 347 $v->print( "\n##### run of 'lilypond " . $opts . "'" ); 348 $output = `lilypond $opts 2>$temp_file`; 349 die "Program lilypond does not work, see '$temp_file': $?" 350 if ( $? ); 351 chomp $output; 352 &shell_handling($output, $temp_file); 353 $v->print( "##### end run of 'lilypond'\n" ); 354 355 # stay in temp dir 356} # end sub run_lilypond() 357 358 359sub shell_handling { 360 # Handle ``-shell-command output in a string (arg1). 361 # stderr goes to temporary file $TempFile. 362 363 our ( $out, $v, $Args ); 364 365 my $out_string = shift; 366 my $temp_file = shift; 367 368 my $a = &string2array($out_string); # array ref 369 for ( @$a ) { 370 $out->print( $_ ); 371 } 372 373 $temp_file && -f $temp_file && -r $temp_file || 374 die "shell_handling(): $temp_file is not a readable file."; 375 my $temp = new FH_READ_FILE($temp_file); 376 my $res = $temp->read_all(); 377 for ( @$res ) { 378 chomp; 379 $v->print($_); 380 } 381 382 unlink $temp_file unless ( $Args->{'keep_all'} ); 383} # end sub shell_handling() 384 385 386sub string2array { 387 my $s = shift; 388 my @a = (); 389 for ( split "\n", $s ) { 390 chomp; 391 push @a, $_; 392 } 393 return \@a; 394} # end string2array() 395 396 397sub usage { # for '--help' 398 our ( $Globals, $Args ); 399 400 my $p = $Globals->{'prog'}; 401 my $usage = EMPTYSTRING; 402 $usage = '###### usage:' . "\n" if ( $Args->{'verbose'} ); 403 $usage .= qq*Options for $p: 404Read a 'roff' file or standard input and transform 'lilypond' parts 405(everything between '.lilypond start' and '.lilypond end') into 406'EPS'-files that can be read by groff using '.PSPIC'. 407 408There is also a command '.lilypond include <file_name>' that can 409include a complete 'lilypond' file into the 'groff' document. 410 411 412# Breaking options: 413$p -?|-h|--help|--usage # usage 414$p --version # version information 415$p --license # the license is GPL >= 3 416 417 418# Normal options: 419$p [options] [--] [filename ...] 420 421There are 2 options for influencing the way how the 'EPS' files for the 422'roff' display are generated: 423--ly2eps 'lilypond' generates 'EPS' files directly (default) 424--pdf2eps 'lilypond' generates a 'PDF' file that is transformed 425 426-k|--keep_all do not delete any temporary files 427-v|--verbose print much information to STDERR 428 429Options with an argument: 430-e|--eps_dir=... use a directory for the EPS files 431-o|--output=... sent output in the groff language into file ... 432-p|--prefix=... start for the names of temporary files 433-t|--temp_dir=... provide the directory for temporary files. 434 435The directories set are created when they do not exist. 436*; 437 438 # old options: 439 # --keep_files -k: do not delete any temporary files 440 # --file_prefix=... -p: start for the names of temporary files 441 442 $main::stdout->print( $usage ); 443} # end sub usage() 444 445 446sub version { # for '--version' 447 our ( $Globals, $Legalese, $stdout, $Args ); 448 my $end; 449 if ( $Globals->{'groff_version'} ) { 450 $end = " version $Globals->{'groff_version'}"; 451 } else { 452 $end = '.'; 453 } 454 455 my $output = EMPTYSTRING; 456 $output = "###### version:\n" if ( $Args->{'verbose'} ); 457 $output .= "'" . $Globals->{'prog'} . "' version '" . 458 $Legalese->{'version'} . "' is part of 'GNU groff'" . $end; 459 460 $stdout->print($output); 461} # end sub version() 462 463 464# end of subs 465 4661; 467######################################################################## 468### Emacs settings 469# Local Variables: 470# mode: CPerl 471# End: 472