src/ssic.pl

   1 #!/usr/bin/perl
   2 #
   3 # Copyright (C) 2013  Patrick "P. J." McDermott
   4 #
   5 # This program is free software: you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation, either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 use strict;
  19 use warnings;
  20
  21 use Getopt::Long;
  22 use CGI::SSI;
  23
  24 sub main
  25 {
  26         my %opts;
  27         my $ssi;
  28         my $input;
  29         my $output;
  30
  31         $SIG{'__WARN__'} = \&warning;
  32
  33         Getopt::Long::Configure("no_ignore_case", "bundling", "gnu_compat",
  34                 "no_getopt_compat");
  35         if (not GetOptions(\%opts,
  36                         "o=s",
  37                         "D=s%",
  38                         "I=s",
  39                         "h|help",
  40                         "V|version",
  41                 )) {
  42                 usage(*STDERR);
  43                 exit(4);
  44         }
  45
  46         if (exists($opts{'h'})) {
  47                 help(*STDOUT);
  48                 exit(0);
  49         }
  50         if (exists($opts{'V'})) {
  51                 version(*STDOUT);
  52                 exit(0);
  53         }
  54
  55         if ($#ARGV lt 0) {
  56                 error(4, "No input files\n");
  57         }
  58
  59         $ssi = init_compiler($opts{'D'}, $opts{'I'});
  60
  61         if (exists($opts{'o'})) {
  62                 if ($#ARGV gt 0) {
  63                         error(4, "Cannot specify -o with multiple files\n");
  64                 }
  65                 compile($ssi, $ARGV[0], $opts{'o'});
  66         } else {
  67                 for $input (@ARGV) {
  68                         $output = $input;
  69                         $output =~ s/\.[^.]+$/.html/;
  70                         compile($ssi, $input, $output);
  71                 }
  72         }
  73
  74         undef $ssi;
  75 }
  76
  77 sub usage
  78 {
  79         my ($fh) = @_;
  80
  81         printf($fh "Usage: %s [-o <output>] <input> ...\n", $0);
  82 }
  83
  84 sub help
  85 {
  86         my ($fh) = @_;
  87
  88         usage($fh);
  89         print("Options:\n");
  90         print("  -D <name>=<value>  Set the variable <name> to <value>\n");
  91         print("  -I <directory>     Set the document root to <directory>\n");
  92         print("  -o <output>        Place the output into <output>\n");
  93         print("  -h, --help         Display this information\n");
  94         print("  -V, --version      Display compiler version information\n");
  95 }
  96
  97 sub version
  98 {
  99         my ($fh) = @_;
 100
 101         print("ssic 0.1.0\n");
 102         print("Copyright (C) 2013 Patrick \"P. J.\" McDermott\n");
 103         print("License GPLv3+: GNU GPL version 3 or later " .
 104                 "<http://gnu.org/licenses/gpl.html>.\n");
 105         print("This is free software: you are free to change and " .
 106                 "redistribute it.\n");
 107         print("There is NO WARRANTY, to the extent permitted by law.\n");
 108 }
 109
 110 sub warning
 111 {
 112         my ($fmt, @args) = @_;
 113
 114         printf(STDERR "ssic: Warning: " . $fmt, @args);
 115 }
 116
 117 sub error
 118 {
 119         my ($status, $fmt, @args) = @_;
 120
 121         printf(STDERR "ssic: Error: " . $fmt, @args);
 122         exit($status);
 123 }
 124
 125 sub init_compiler
 126 {
 127         my ($vars, $root) = @_;
 128         my $ssi;
 129         my $var_name;
 130         my $var_value;
 131
 132         %ENV = (
 133                 "DOCUMENT_ROOT" => $root,
 134         );
 135
 136         $CGI::SSI::DEBUG = 0;
 137         $ssi = CGI::SSI->new();
 138
 139         $ssi->set("DOCUMENT_ROOT" => $root);
 140
 141         while (($var_name, $var_value) = each(%{$vars})) {
 142                 $ssi->set($var_name => $var_value);
 143         }
 144
 145         return $ssi;
 146 }
 147
 148 sub compile
 149 {
 150         my ($ssi, $input, $output) = @_;
 151         my $input_fh;
 152         my $input_abs;
 153         my $output_fh;
 154
 155         if ($input eq $output and $input ne "-") {
 156                 warning("Input and output files are equal\n");
 157         }
 158
 159         if ($input eq "-") {
 160                 $input_fh = *STDIN;
 161                 $input_abs = File::Spec->rel2abs(".");
 162         } else {
 163                 if (not open($input_fh, "<", $input)) {
 164                         error(4, "%s: %s\n", $input, $!);
 165                 }
 166                 $input_abs = File::Spec->rel2abs($input);
 167         }
 168         if ($output eq "-") {
 169                 $output_fh = *STDOUT;
 170         } else {
 171                 if (not open($output_fh, ">", $output . "~")) {
 172                         error(4, "%s: %s\n", $output . "~", $!);
 173                 }
 174         }
 175
 176         # CGI::SSI uses SCRIPT_FILENAME to determine the value of LAST_MODIFIED.
 177         $ENV{"DOCUMENT_NAME"} = $input;
 178         $ENV{"DOCUMENT_URI"} = $input;
 179         $ENV{"SCRIPT_FILENAME"} = $input_abs;
 180
 181         # Reset config tags to default values.
 182         $ssi->config("errmsg",
 183                 "[an error occurred while processing this directive]");
 184         $ssi->config("sizefmt", "abbrev");
 185         $ssi->config("timefmt", undef);
 186
 187         $ssi->set("DOCUMENT_NAME" => $input);
 188         $ssi->set("DOCUMENT_URI" => $input);
 189
 190         print($output_fh $ssi->process(<$input_fh>));
 191
 192         if ($input ne "-") {
 193                 close($input_fh);
 194         }
 195         if ($output ne "-") {
 196                 close($output_fh);
 197                 if (not rename($output . "~", $output)) {
 198                         error(4, "%s: %s\n", $output, $!);
 199                 }
 200         }
 201 }
 202
 203 main();