| Current File : //usr/bin/gperl |
#! /usr/bin/perl
# gperl - add Perl part to groff files, this is the preprocessor for that
# Source file position: <groff-source>/contrib/gperl/gperl.pl
# Installed position: <prefix>/bin/gperl
# Copyright (C) 2014-2018 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 '1.22.4' 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'} = '/usr/bin';
$at_at{'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 q('gperl' 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;
########################################################################
### Emacs settings
# Local Variables:
# mode: CPerl
# End: