contrib/gperl/gperl.pl

   1 #! /usr/bin/env perl
   2
   3 # gperl - add Perl part to groff files, this is the preprocessor for that
   4
   5 # Source file position: <groff-source>/contrib/gperl/gperl.pl
   6 # Installed position: <prefix>/bin/gperl
   7
   8 # Copyright (C) 2014-2018 Free Software Foundation, Inc.
   9
  10 # Written by Bernd Warken <groff-bernd.warken-72@web.de>.
  11
  12 my $version = '1.2.6';
  13
  14 # This file is part of 'gperl', which is part of 'groff'.
  15
  16 # 'groff' is free software; you can redistribute it and/or modify it
  17 # under the terms of the GNU General Public License as published by
  18 # the Free Software Foundation, either version 2 of the License, or
  19 # (at your option) any later version.
  20
  21 # 'groff' is distributed in the hope that it will be useful, but
  22 # WITHOUT ANY WARRANTY; without even the implied warranty of
  23 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24 # General Public License for more details.
  25
  26 # You can find a copy of the GNU General Public License in the internet
  27 # at <http://www.gnu.org/licenses/gpl-2.0.html>.
  28
  29 ########################################################################
  30
  31 use strict;
  32 use warnings;
  33 #use diagnostics;
  34
  35 # temporary dir and files
  36 use File::Temp qw/ tempfile tempdir /;
  37
  38 # needed for temporary dir
  39 use File::Spec;
  40
  41 # for 'copy' and 'move'
  42 use File::Copy;
  43
  44 # for fileparse, dirname and basename
  45 use File::Basename;
  46
  47 # current working directory
  48 use Cwd;
  49
  50 # $Bin is the directory where this script is located
  51 use FindBin;
  52
  53
  54 ########################################################################
  55 # system variables and exported variables
  56 ########################################################################
  57
  58 $\ = "\n";      # final part for print command
  59
  60 ########################################################################
  61 # read-only variables with double-@ construct
  62 ########################################################################
  63
  64 our $File_split_env_sh;
  65 our $File_version_sh;
  66 our $Groff_Version;
  67
  68 my $before_make;                # script before run of 'make'
  69 {
  70   my $at = '@';
  71   $before_make = 1 if '@VERSION@' eq "${at}VERSION${at}";
  72 }
  73
  74 my %at_at;
  75 my $file_perl_test_pl;
  76 my $groffer_libdir;
  77
  78 if ($before_make) {
  79   my $gperl_source_dir = $FindBin::Bin;
  80   $at_at{'BINDIR'} = $gperl_source_dir;
  81   $at_at{'G'} = '';
  82 } else {
  83   $at_at{'BINDIR'} = '@BINDIR@';
  84   $at_at{'G'} = '@g@';
  85 }
  86
  87
  88 ########################################################################
  89 # options
  90 ########################################################################
  91
  92 foreach (@ARGV) {
  93   if ( /^(-h|--h|--he|--hel|--help)$/ ) {
  94     print q(Usage for the 'gperl' program:);
  95     print 'gperl [-] [--] [filespec...] normal file name arguments';
  96     print 'gperl [-h|--help]        gives usage information';
  97     print 'gperl [-v|--version]     displays the version number';
  98     print q(This program is a 'groff' preprocessor that handles Perl ) .
  99       q(parts in 'roff' files.);
 100     exit;
 101   } elsif ( /^(-v|--v|--ve|--ver|--vers|--versi|--versio|--version)$/ ) {
 102     print q('gperl' version ) . $version;
 103     exit;
 104   }
 105 }
 106
 107
 108 #######################################################################
 109 # temporary file
 110 #######################################################################
 111
 112 my $out_file;
 113 {
 114   my $template = 'gperl_' . "$$" . '_XXXX';
 115   my $tmpdir;
 116   foreach ($ENV{'GROFF_TMPDIR'}, $ENV{'TMPDIR'}, $ENV{'TMP'}, $ENV{'TEMP'},
 117            $ENV{'TEMPDIR'}, 'tmp', $ENV{'HOME'},
 118            File::Spec->catfile($ENV{'HOME'}, 'tmp')) {
 119     if ($_ && -d $_ && -w $_) {
 120       eval { $tmpdir = tempdir( $template,
 121                                 CLEANUP => 1, DIR => "$_" ); };
 122       last if $tmpdir;
 123     }
 124   }
 125   $out_file = File::Spec->catfile($tmpdir, $template);
 126 }
 127
 128
 129 ########################################################################
 130 # input
 131 ########################################################################
 132
 133 my $perl_mode = 0;
 134
 135 foreach (<>) {
 136   chomp;
 137   s/\s+$//;
 138   my $line = $_;
 139   my $is_dot_Perl = $line =~ /^[.']\s*Perl(|\s+.*)$/;
 140
 141   unless ( $is_dot_Perl ) {     # not a '.Perl' line
 142     if ( $perl_mode ) {         # is running in Perl mode
 143       print OUT $line;
 144     } else {                    # normal line, not Perl-related
 145       print $line;
 146     }
 147     next;
 148   }
 149
 150
 151   ##########
 152   # now the line is a '.Perl' line
 153
 154   my $args = $line;
 155   $args =~ s/\s+$//;    # remove final spaces
 156   $args =~ s/^[.']\s*Perl\s*//; # omit .Perl part, leave the arguments
 157
 158   my @args = split /\s+/, $args;
 159
 160   ##########
 161   # start Perl mode
 162   if ( @args == 0 || @args == 1 && $args[0] eq 'start' ) {
 163     # For '.Perl' no args or first arg 'start' means opening 'Perl' mode.
 164     # Everything else means an ending command.
 165     if ( $perl_mode ) {
 166       # '.Perl' was started twice, ignore
 167       print STDERR q('.Perl' starter was run several times);
 168       next;
 169     } else {    # new Perl start
 170       $perl_mode = 1;
 171       open OUT, '>', $out_file;
 172       next;
 173     }
 174   }
 175
 176   ##########
 177   # now the line must be a Perl ending line (stop)
 178
 179   unless ( $perl_mode ) {
 180     print STDERR 'gperl: there was a Perl ending without being in ' .
 181       'Perl mode:';
 182     print STDERR '    ' . $line;
 183     next;
 184   }
 185
 186   $perl_mode = 0;       # 'Perl' stop calling is correct
 187   close OUT;            # close the storing of 'Perl' commands
 188
 189   ##########
 190   # run this 'Perl' part, later on about storage of the result
 191   # array stores prints with \n
 192   my @print_res = `perl $out_file`;
 193
 194   # remove 'stop' arg if exists
 195   shift @args if ( $args[0] eq 'stop' );
 196
 197   if ( @args == 0 ) {
 198     # no args for saving, so @print_res doesn't matter
 199     next;
 200   }
 201
 202   my @var_names = ();
 203   my @mode_names = ();
 204
 205   my $mode = '.ds';
 206   for ( @args ) {
 207     if ( /^\.?ds$/ ) {
 208       $mode = '.ds';
 209       next;
 210     }
 211     if ( /^\.?nr$/ ) {
 212       $mode = '.nr';
 213       next;
 214     }
 215     push @mode_names, $mode;
 216     push @var_names, $_;
 217   }
 218
 219   my $n_res = @print_res;
 220   my $n_vars = @var_names;
 221
 222   if ( $n_vars < $n_res ) {
 223     print STDERR 'gperl: not enough variables for Perl part: ' .
 224       $n_vars . ' variables for ' . $n_res . ' output lines.';
 225   } elsif ( $n_vars > $n_res ) {
 226     print STDERR 'gperl: too many variablenames for Perl part: ' .
 227       $n_vars . ' variables for ' . $n_res . ' output lines.';
 228   }
 229   if ( $n_vars < $n_res ) {
 230     print STDERR 'gperl: not enough variables for Perl part: ' .
 231       $n_vars . ' variables for ' . $n_res . ' output lines.';
 232   }
 233
 234   my $n_min = $n_res;
 235   $n_min = $n_vars if ( $n_vars < $n_res );
 236   exit unless ( $n_min );
 237   $n_min -= 1; # for starting with 0
 238
 239   for my $i ( 0..$n_min ) {
 240     my $value = $print_res[$i];
 241     chomp $value;
 242     print $mode_names[$i] . ' ' . $var_names[$i] . ' ' . $value;
 243   }
 244 }
 245
 246
 247 1;
 248 ########################################################################
 249 ### Emacs settings
 250 # Local Variables:
 251 # mode: CPerl
 252 # End: