diff options
Diffstat (limited to 'contrib/gperl/gperl.pl')
| -rwxr-xr-x | contrib/gperl/gperl.pl | 257 |
1 files changed, 257 insertions, 0 deletions
diff --git a/contrib/gperl/gperl.pl b/contrib/gperl/gperl.pl new file mode 100755 index 0000000..2f9f7d1 --- /dev/null +++ b/contrib/gperl/gperl.pl @@ -0,0 +1,257 @@ +#! /usr/bin/env perl + +# gperl - add Perl part to groff files, this is the preprocessor for that + +# Copyright (C) 2014-2020 Free Software Foundation, Inc. + +# Written by Bernd Warken <groff-bernd.warken-72@web.de>. + +my $version = '1.2.6'; + +# This file is part of 'gperl', which is part of 'groff'. + +# '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 2 of the License, or +# (at your option) any later version. + +# '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 can find a copy of the GNU General Public License in the internet +# at <http://www.gnu.org/licenses/gpl-2.0.html>. + +######################################################################## + +use strict; +use warnings; +#use diagnostics; + +# temporary dir and files +use File::Temp qw/ tempfile tempdir /; + +# needed for temporary dir +use File::Spec; + +# for 'copy' and 'move' +use File::Copy; + +# for fileparse, dirname and basename +use File::Basename; + +# current working directory +use Cwd; + +# $Bin is the directory where this script is located +use FindBin; + + +######################################################################## +# system variables and exported variables +######################################################################## + +$\ = "\n"; # final part for print command + +######################################################################## +# read-only variables with double-@ construct +######################################################################## + +our $File_split_env_sh; +our $File_version_sh; +our $Groff_Version; + +my $before_make; # script before run of 'make' +{ + my $at = '@'; + $before_make = 1 if '@VERSION@' eq "${at}VERSION${at}"; +} + +my %at_at; +my $file_perl_test_pl; +my $groffer_libdir; + +if ($before_make) { + my $gperl_source_dir = $FindBin::Bin; + $at_at{'BINDIR'} = $gperl_source_dir; + $at_at{'G'} = ''; +} else { + $at_at{'BINDIR'} = '@BINDIR@'; + $at_at{'G'} = '@g@'; +} + + +######################################################################## +# options +######################################################################## + +foreach (@ARGV) { + if ( /^(-h|--h|--he|--hel|--help)$/ ) { + print q(Usage for the 'gperl' program:); + print 'gperl [-] [--] [filespec...] normal file name arguments'; + print 'gperl [-h|--help] gives usage information'; + print 'gperl [-v|--version] displays the version number'; + print q(This program is a 'groff' preprocessor that handles Perl ) . + q(parts in 'roff' files.); + exit; + } elsif ( /^(-v|--v|--ve|--ver|--vers|--versi|--versio|--version)$/ ) { + print "gperl (groff @VERSION@) version $version"; + exit; + } +} + + +####################################################################### +# temporary file +####################################################################### + +my $out_file; +{ + my $template = 'gperl_' . "$$" . '_XXXX'; + my $tmpdir; + foreach ($ENV{'GROFF_TMPDIR'}, $ENV{'TMPDIR'}, $ENV{'TMP'}, $ENV{'TEMP'}, + $ENV{'TEMPDIR'}, 'tmp', $ENV{'HOME'}, + File::Spec->catfile($ENV{'HOME'}, 'tmp')) { + if ($_ && -d $_ && -w $_) { + eval { $tmpdir = tempdir( $template, + CLEANUP => 1, DIR => "$_" ); }; + last if $tmpdir; + } + } + $out_file = File::Spec->catfile($tmpdir, $template); +} + + +######################################################################## +# input +######################################################################## + +my $perl_mode = 0; + +unshift @ARGV, '-' unless @ARGV; +foreach my $filename (@ARGV) { + my $input; + if ($filename eq '-') { + $input = \*STDIN; + } elsif (not open $input, '<', $filename) { + warn $!; + next; + } + while (<$input>) { + chomp; + s/\s+$//; + my $line = $_; + my $is_dot_Perl = $line =~ /^[.']\s*Perl(|\s+.*)$/; + + unless ( $is_dot_Perl ) { # not a '.Perl' line + if ( $perl_mode ) { # is running in Perl mode + print OUT $line; + } else { # normal line, not Perl-related + print $line; + } + next; + } + + + ########## + # now the line is a '.Perl' line + + my $args = $line; + $args =~ s/\s+$//; # remove final spaces + $args =~ s/^[.']\s*Perl\s*//; # omit .Perl part, leave the arguments + + my @args = split /\s+/, $args; + + ########## + # start Perl mode + if ( @args == 0 || @args == 1 && $args[0] eq 'start' ) { + # For '.Perl' no args or first arg 'start' means opening 'Perl' mode. + # Everything else means an ending command. + if ( $perl_mode ) { + # '.Perl' was started twice, ignore + print STDERR q('.Perl' starter was run several times); + next; + } else { # new Perl start + $perl_mode = 1; + open OUT, '>', $out_file; + next; + } + } + + ########## + # now the line must be a Perl ending line (stop) + + unless ( $perl_mode ) { + print STDERR 'gperl: there was a Perl ending without being in ' . + 'Perl mode:'; + print STDERR ' ' . $line; + next; + } + + $perl_mode = 0; # 'Perl' stop calling is correct + close OUT; # close the storing of 'Perl' commands + + ########## + # run this 'Perl' part, later on about storage of the result + # array stores prints with \n + my @print_res = `perl $out_file`; + + # remove 'stop' arg if exists + shift @args if ( $args[0] eq 'stop' ); + + if ( @args == 0 ) { + # no args for saving, so @print_res doesn't matter + next; + } + + my @var_names = (); + my @mode_names = (); + + my $mode = '.ds'; + for ( @args ) { + if ( /^\.?ds$/ ) { + $mode = '.ds'; + next; + } + if ( /^\.?nr$/ ) { + $mode = '.nr'; + next; + } + push @mode_names, $mode; + push @var_names, $_; + } + + my $n_res = @print_res; + my $n_vars = @var_names; + + if ( $n_vars < $n_res ) { + print STDERR 'gperl: not enough variables for Perl part: ' . + $n_vars . ' variables for ' . $n_res . ' output lines.'; + } elsif ( $n_vars > $n_res ) { + print STDERR 'gperl: too many variablenames for Perl part: ' . + $n_vars . ' variables for ' . $n_res . ' output lines.'; + } + if ( $n_vars < $n_res ) { + print STDERR 'gperl: not enough variables for Perl part: ' . + $n_vars . ' variables for ' . $n_res . ' output lines.'; + } + + my $n_min = $n_res; + $n_min = $n_vars if ( $n_vars < $n_res ); + exit unless ( $n_min ); + $n_min -= 1; # for starting with 0 + + for my $i ( 0..$n_min ) { + my $value = $print_res[$i]; + chomp $value; + print $mode_names[$i] . ' ' . $var_names[$i] . ' ' . $value; + } + } +} + + +1; +# Local Variables: +# mode: CPerl +# End: |