blob: ff4c1ccd22f8a36faf26b10c84b7b585f3583f9f [file] [log] [blame]
#!/usr/bin/perl
#
# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements. See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership. The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License. You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied. See the License for the
# specific language governing permissions and limitations
# under the License.
#
# SLZY_HDR_END
use POSIX;
use Pod::Usage;
use Getopt::Long;
use Data::Dumper;
use JSON;
use strict;
use warnings;
# SLZY_POD_HDR_BEGIN
# WARNING: DO NOT MODIFY THE FOLLOWING POD DOCUMENT:
# Generated by sleazy.pl version 9 (release Fri Feb 1 15:51:48 2013)
# Make any changes under SLZY_TOP_BEGIN/SLZY_LONG_BEGIN
=head1 NAME
B<sleazy.pl> - an easy way to go
=head1 VERSION
This document describes version 9 of sleazy.pl, released
Mon Feb 4 13:03:01 2013.
=head1 SYNOPSIS
B<sleazy.pl>
Options:
-help brief help message
-man full documentation
-define define a general property
-dbg dbg
-showproperties print out property definitions
-incversion increment version number
-maketemplate make a sleazy template
=head1 OPTIONS
=over 8
=item B<-help>
Print a brief help message and exits.
=item B<-man>
Prints the manual page and exits.
=item B<-define>
Define a general property of the form key=value. Note that
multiple definitions are possible, eg:
--define AUTHORNAME="joe tool" --define COPYDATES="2010,2011"
=item B<-dbg>
dbg
=item B<-showproperties>
print out property definitions
=item B<-incversion>
increment version number
=item B<-maketemplate>
Generate a sleazy template for a program. You supply the rest.
=back
=head1 DESCRIPTION
sleazy uses templates to construct programs and documentation. The
program is defined using a JSON data structure stored in a HERE
document in the SLZY_TOP_BEGIN/END block. The JSON doc describes the
program arguments, their names and types, and provides basic
documentation. Use sleazy.pl to convert your program template into
actual code.
=head2 JSON doc
sleazy can convert a tiny program description into
grammatically-correct JSON. For example, the spec:
n: my name is foo
gets converted to
"name" : "my name is foo"
The top-level fields are:
=over 8
=item short (abbreviation "s")
The short description of the program.
=item long (abbreviation "l")
The long description of the program. For readability, you can
construct the long description as a separate HERE doc in the
SLZY_LONG_BEGIN/END block, and use the variable name instead, eg:
"long" : "$longdesc"
will pick up the long description "my $longdesc" from SLZY_LONG_BEGIN
=item args (abbreviation "a")
An array of arguments. The easiest spec is a single-line array of
comma-separated argument names, eg:
a: [argname1, argname2, argname3]
becomes:
"args" : [
{
"name" : "argname1",
"type" : "u"
},
{
"name" : "argname2",
"type" : "u"
},
{
"name" : "argname3",
"type" : "u"
}
=item version (abbreviation "vz")
If version is not specified, the program is labelled as version 0.
=item properties (no abbreviation)
Properties can contain a series of scalar values for various program
properties, eg the AUTHORNAME for the author or COPYDATES for
copyright dates. By default it contains the slzy_date, the time that
the program was last regenerated.
When a new program is generated, the basic properties (eg AUTHORNAME,
COPYDATES) are derived from the user environment, or taken the from
HOME/sleazyprop.json file (if it exists). You can override these
settings with an explicit "-define" option on the command line, eg:
sleazy.pl -define AUTHORNAME="Thomas Jefferson" constitution.pl
will reset the author of constitution.pl to Thomas Jefferson.
=back
=head1 Usage
After you update JSON description, you must run sleazy.pl to
regenerate the target file. Note that sleazy.pl does not overwrite
the input file. Instead, it generates an updated version of the file
with a .slzy extension, ie:
=over 8
perl sleazy.pl foo.pl
=back
creates an updated foo.pl.slzy file. The user must manually replace
the existing .pl file.
=head2 sleazyprop.json
You can set default properties in sleazyprop.json in your home
directory. The format of this document is the same as the output of
the "-showproperties" command. Typical settings are the AUTHORNAME,
BUGEMAIL address, and COPYHOLDER (copyright holder). You can override
these properties using "-define" command-line settings.
=head1 Argument Types
sleazy.pl distinguishes between "typed" and "untyped" arguments. An
"untyped" argument is just a flag that is set (or unset). A "typed"
argument takes a value that immediately follows the named flag (either
"-argname argval" or "-argname=argval" will work).
The argument types are:
=over 8
=item untyped (default)
Not typed.
=item string
a string.
=item int
An integer. (non-integer values are mysteriously set to zero).
=item file
An existing file -- if the file is non-existent or inaccessible the
program will error out. If you wish to specify a filename for a new
file use "outfile".
=item outfile
An output file. No existence check is performed.
=back
=head2 Argument Type Options
Normally, arguments are scalar attributes of the glob_glob hash, eg
"-name=value" results in a setting of glob_glob->{name}="value", and
multiple settings of the same flag result in the last setting taking
precedence. To allow multiple specifications of an argument, the
argument types optionally take an array or hash suffix, eg "string%"
allows for a hash of strings, or use "string[]" or "string@" for an
array.
=head1 CAVEATS/Future Work
Perl Getopt::Long and sleazy distinguish "required" and "optional"
arguments slightly differently. For starters, sleazy refers to them
as "arguments", and Getopt::Long calls them "options". The sleazy
"argument name" is the Getopt command-line flag for an option. But it
is so much easier to talk about optional arguments versus optional
options. For sleazy, if an argument is "untyped", then it does not
take a value, and it can only be optional -- that is, the flag is set
or unset. If an argument is typed, then the command-line flag is
always followed by a value, and the "flag plus value" can be optional
or required. GetOpt::Long uses "required" and "optional" to
distinguish whether a flag must be followed by a value, not whether
the flag itself is required or optional. We may want to approach this
by adding the concept of default values with a "set" and "unset"
context. If the flag is not specified, then the "unset" default is
used. If the flag is set, but no value is supplied, then the "set"
default is used. If the flag is set and an argument value is supplied
then that value is used.
=head1 AUTHORS
Apache HAWQ
Address bug reports and comments to: dev@hawq.incubator.apache.org
=cut
# SLZY_POD_HDR_END
# SLZY_GLOB_BEGIN
my $glob_id = "";
#my $glob_tabstr = "\t";
#my $glob_tabstr = " " x $glob_tabwidth;
my $glob_glob2 = {tabwidth => 4, spacedtab => 1, tabstr => " " x 4};
my $glob_glob;
# SLZY_GLOB_END
sub load_properties
{
my $allproph = shift;
my $proplistfil = File::Spec->catfile($ENV{HOME}, "sleazyprop.json");
# order of precedence when adding/defining properties:
# command-line "-define" overrules everything
# pre-existing properties overrule proplistfile
# proplistfile can only define new properties
if (-e $proplistfil)
{
my $injson;
open $injson, "< $proplistfil"
or die "cannot open $proplistfil: $!";
# $$$ $$$ undefine input record separator (\n)
# and slurp entire file into variable
local $/;
undef $/;
my $whole_file = <$injson>;
close $injson;
my $proph = JSON::from_json($whole_file);
while (my ($kk, $vv) = each(%{$proph}))
{
$allproph->{$kk} = $vv
unless (exists($allproph->{$kk}));
}
}
if (exists($glob_glob->{define}))
{
while (my ($kk, $vv) = each(%{$glob_glob->{define}}))
{
$allproph->{$kk} = $vv;
}
}
# this is a little misleading: the "properties" entry from the
# json spec has not been loaded yet. The properties defined in
# the initial BEGIN block are from the *previous* revision of the
# program.
print Data::Dumper->Dump([$glob_glob])
if (exists($glob_glob->{dbg}));
} # end load_properties
sub glob_validate
{
load_properties($glob_glob->{_sleazy_properties});
}
# SLZY_CMDLINE_BEGIN
# WARNING: DO NOT MODIFY THE FOLLOWING SECTION:
# Generated by sleazy.pl version 9 (release Fri Feb 1 15:51:48 2013)
# Make any changes under SLZY_TOP_BEGIN/SLZY_LONG_BEGIN
# Any additional validation logic belongs in glob_validate()
BEGIN {
my $s_help = 0; # brief help message
my $s_man = 0; # full documentation
my $s_define; # define a general property
my $s_dbg; #
my $s_showproperties = 0; # print out property definitions
my $s_incversion; # increment version number
my $s_maketemplate; # make a sleazy template
my $slzy_argv_str;
$slzy_argv_str = quotemeta(join(" ", @ARGV))
if (scalar(@ARGV));
GetOptions(
'help|?' => \$s_help,
'man' => \$s_man,
'define:s%' => \$s_define,
'dbg' => \$s_dbg,
'showproperties|showprops|showproperty' => \$s_showproperties,
'incversion' => \$s_incversion,
'maketemplate|template|tmpl' => \$s_maketemplate,
)
or pod2usage(2);
pod2usage(-msg => $glob_id, -exitstatus => 1) if $s_help;
pod2usage(-msg => $glob_id, -exitstatus => 0, -verbose => 2) if $s_man;
$glob_glob = {};
# version and properties from json definition
$glob_glob->{_sleazy_properties} = {};
$glob_glob->{_sleazy_properties}->{version} = '9';
$glob_glob->{_sleazy_properties}->{AUTHORNAME} = 'Jeffrey I Cohen';
$glob_glob->{_sleazy_properties}->{BUGEMAIL} = 'Address bug reports and comments to: jcohen@greenplum.com';
$glob_glob->{_sleazy_properties}->{COPYDATES} = '2012, 2013';
$glob_glob->{_sleazy_properties}->{COPYHOLDER} = 'Greenplum';
$glob_glob->{_sleazy_properties}->{slzy_date} = '1360011781';
$glob_glob->{_sleazy_properties}->{slzy_argv_str} = $slzy_argv_str;
$glob_glob->{define} = $s_define if (defined($s_define));
$glob_glob->{dbg} = $s_dbg if (defined($s_dbg));
$glob_glob->{showproperties} = $s_showproperties if (defined($s_showproperties));
$glob_glob->{incversion} = $s_incversion if (defined($s_incversion));
$glob_glob->{maketemplate} = $s_maketemplate if (defined($s_maketemplate));
glob_validate();
}
# SLZY_CMDLINE_END
sub perl_pod_docversion
{
my $bigstr = <<'EOF_bigstr';
{HEAD1} VERSION
This document describes version {VERSION} of {PROGNAME}, released
{DOCDATE}.
EOF_bigstr
return $bigstr;
} # end perl_pod_docversion
sub perl_pod_header
{
my $bigstr = <<'EOF_bigstr';
{HEAD1} NAME
B<{PROGNAME}> - {SHORTDESCRIPTION}
{DOCVERSION}
{HEAD1} SYNOPSIS
B<{PROGNAME}> {PROGOPTIONS}
Options:
{OPTIONS}
{HEAD1} OPTIONS
{PODOVER8}
{PODITEMS}
{PODBACK}
{HEAD1} DESCRIPTION
{LONGDESCRIPTION}
{HEAD1} AUTHORS
{AUTHORNAME}
Copyright (c) {COPYDATES} {COPYHOLDER}. All rights reserved.
{BUGEMAIL}
{PODCUT}
EOF_bigstr
return $bigstr;
} # end perl_pod_header
sub perl_getopt_func
{
my $bigstr = <<'EOF_bigstr';
BEGIN {
{VARLIST}
my $slzy_argv_str;
$slzy_argv_str = quotemeta(join(" ", @ARGV))
if (scalar(@ARGV));
GetOptions(
{GETOPTVARLIST}
)
or pod2usage(2);
{SETGLOB}
}
EOF_bigstr
return $bigstr;
} # end perl_getopt_func
sub sleazy_perl_template
{
my $tttstr = <<'EOF_tttstr';
#!/usr/bin/perl
#
# $Header: $
#
# copyright (c) {COPYDATES}
# Author: {AUTHORNAME}
#
# {SLZY}HDR_END
use POSIX;
use Pod::Usage;
use Getopt::Long;
use Data::Dumper;
use strict;
use warnings;
# {SLZY}POD_HDR_BEGIN
# pod header gets generated here
# {SLZY}POD_HDR_END
# {SLZY}GLOB_BEGIN
my $glob_id;
my $glob_glob;
# {SLZY}GLOB_END
# stub for global validation function
sub glob_validate
{
}
# {SLZY}CMDLINE_BEGIN
# getopt::long processing here
# {SLZY}CMDLINE_END
# {SLZY}TOP_BEGIN
if (0)
{
my $bigstr = <<'EOF_bigstr';
{
"short" : basic sleazy template
}
EOF_bigstr
}
# {SLZY}TOP_END
# {SLZY}LONG_BEGIN
if (0)
{
# Construct a series of "Here" documents to contain formatted long
# strings for the JSON document.
my $toplong = <<'EOF_longstr';
This long string is not very long
EOF_longstr
}
# {SLZY}LONG_END
EOF_tttstr
return $tttstr;
} # end sleazy_perl_template
sub doformat
{
my ($bigstr, $kv) = @_;
my %blankprefix;
# find format expressions with leading blanks
if ($bigstr =~ m/\n/)
{
my @foo = split(/\n/, $bigstr);
for my $lin (@foo)
{
next unless ($lin =~ m/^\s+\{.*\}/);
# find the first format expression after the blank prefix
my @baz = split(/\}/, $lin, 2);
my $firstf = shift @baz;
my @zzz = ($firstf =~ m/^(\s+)\{(.*)$/);
next unless (defined($zzz[1]) &&
length($zzz[1]));
my $k2 = quotemeta($zzz[1]);
die "duplicate use of prefixed pattern $k2"
if (exists($blankprefix{$k2}));
# store the prefix
$blankprefix{$k2} = $zzz[0];
}
}
# print Data::Dumper->Dump([%blankprefix]);
while (my ($kk, $vv) = each(%{$kv}))
{
my $subi = '{' . quotemeta($kk) . '}';
my $v2 = $vv;
if (exists($blankprefix{quotemeta($kk)}) &&
($v2 =~ m/\n/))
{
my @foo = split(/\n/, $v2);
# for a multiline substitution, prefix every line with the
# offset of the original token
$v2 = join("\n" . $blankprefix{quotemeta($kk)}, @foo);
# fixup trailing newline if necessary
if ($vv =~ m/\n$/)
{
$v2 .= "\n"
unless ($v2 =~ m/\n$/);
}
}
$bigstr =~ s/$subi/$v2/gm;
}
return $bigstr;
}
# expects val1, len1, val2, len2
# where length values are based on printed offset, not length(val), ie
# embedded tabs are counted.
sub tabalign
{
my ($tabwidth, $collist) = @_;
my $tabstr = $glob_glob2->{tabstr};
my $maxlen = 0;
for my $coldef (@{$collist})
{
die "bad coldef: " . Data::Dumper->Dump([$coldef])
unless (scalar(@{$coldef}) > 3);
$maxlen = $coldef->[1] if ($coldef->[1] > $maxlen);
}
# find the tab position for the second column
my $col2tab = (POSIX::ceil($maxlen / $tabwidth)) * $tabwidth;
$col2tab++ if ($col2tab == $maxlen);
# print $maxlen, " " , $col2tab, "\n";
# print Data::Dumper->Dump($collist), "\n";
for my $ii (0..(scalar(@{$collist})-1))
{
# print Data::Dumper->Dump($collist->[$ii]), "\n";
my $val1 = shift @{$collist->[$ii]};
my $len1 = shift @{$collist->[$ii]};
my $val2 = shift @{$collist->[$ii]};
my $len2 = shift @{$collist->[$ii]};
my $newval = $val1;
if ($len1 < $col2tab)
{
my $mod1 = $len1 % $tabwidth;
# print "mod: $mod1\n";
if ($mod1)
{
$len1 += ($tabwidth - $mod1);
if ($glob_glob2->{spacedtab})
{
$val1 .= " " x ($tabwidth - $mod1);
}
else
{
$val1 .= $tabstr;
}
}
}
while ($len1 < $col2tab)
{
$len1 += $tabwidth;
$val1 .= $tabstr;
}
unshift @{$collist->[$ii]}, $len1 + $len2 ;
unshift @{$collist->[$ii]}, $val1 . $val2;
} # end for ii
# print Data::Dumper->Dump($collist), "\n";
return $collist;
}
sub simpletabalign
{
my ($col1, $col2) = @_;
my $colitem = [];
push @{$colitem}, $col1;
push @{$colitem}, length($col1);
push @{$colitem}, $col2;
push @{$colitem}, length($col2);
my $collist = tabalign($glob_glob2->{tabwidth}, [$colitem]);
return $collist->[0]->[0];
}
# take a table-format string (columns separated by "|", rows separated
# by newline) and return an array with a single, formatted string row
sub tabalignstr
{
my $str = shift;
my $flist = [];
my @lines = split(/\n/, $str);
return $flist
unless scalar(@lines);
for my $lin (@lines)
{
my @foo = split(/\|/, $lin);
last
unless (scalar(@foo));
my $flitem = [];
for my $itm (@foo)
{
$itm = ""
unless (defined($itm));
push @{$flitem}, $itm, length($itm);
}
push @{$flist}, $flitem;
}
L_bigloop:
while (1)
{
for my $coldef (@{$flist})
{
last L_bigloop
unless (scalar(@{$coldef}) > 3);
}
$flist = tabalign($glob_glob2->{tabwidth}, $flist);
}
my @itmlst;
for my $itm (@{$flist})
{
push @itmlst, shift(@{$itm});
}
return \@itmlst;
} # end tabalignstr
my $validate_reqstr =
'|die ("missing required argument for \'{ARGNAME}\'")' .
"\n" .
'|unless (defined($s_{ARGNAME}));';
my $validate_filestr =
'|if (defined($s_{ARGNAME}))' . "\n" .
'|{' . "\n" .
'|die ("invalid argument for \'{ARGNAME}\': file $s_{ARGNAME} does not exist")' . "\n" .
'|unless (-e $s_{ARGNAME});' . "\n" .
'|}';
sub sleazify_cmdline
{
my ($oldcmdline, $bigh) = @_;
my $cmdline = $oldcmdline;
my $decl = "";
my $getoptarg = "";
my $pipespecial = '`'; # substitute backtick for pipe (|) when
# separating aliases and fix later
my $validator = "";
my $globset = "";
my $gotman = 0;
my $gothelp = 0;
for my $args (@{$bigh->{args}})
{
my $n2 = $args->{name};
my $reqarg = (exists($args->{required}) && $args->{required});
my $dfl;
$gotman = 1 if ($n2 eq "man");
$gothelp = 1 if ($n2 eq "help");
my $n3 = $n2;
my $nalias = "";
$nalias = $args->{alias} if (exists($args->{alias}));
# remove pipe (|) from alias to avoid parsing problem with tabalignstr
$nalias =~ s/\|/$pipespecial/gm;
$n3 .= $pipespecial . $nalias if (exists($args->{alias}));
if (exists($args->{type}))
{
# check if required, and check type
my $reqmod = $reqarg ? "=" : ":" ;
$n3 .= $reqmod . "s"
if ($args->{type} =~ m/^(file|string|outfile)/);
$n3 .= $reqmod . "i" if ($args->{type} =~ m/^int/);
# make an array if ends in '[]' or '@', or a hash if ends in '%'
$n3 .= '@' if ($args->{type} =~ m/((\[\])|\@)$/);
$n3 .= '%' if ($args->{type} =~ m/\%$/);
}
$n3 = '\'' . $n3 . '\'';
$getoptarg .=
$n3 . '| => |\$s_' . $n2 . ",\n";
$globset .= '$glob_glob->{' . $n2 . '}| = |$s_' . $n2 .
' |if (defined($s_' . $n2 . '));' . "\n"
if ($n2 !~ m/^(man|help)/);
$dfl = "";
if (exists($args->{type}))
{
if ($args->{type} =~ m/^u/i)
{
$dfl = "= 0;"
}
# first validate required arguments
if ($reqarg && ($args->{type} =~ m/^(file|string|outfile)/i))
{
$validator .=
doformat($validate_reqstr,
{
ARGNAME => $args->{name}
}
);
$validator .= "\n";
}
# if a file is required, see if it is valid.
if ($args->{type} =~ m/^file/i)
{
$validator .=
doformat($validate_filestr,
{
ARGNAME => $args->{name}
}
);
$validator .= "\n";
}
}
$decl .= '|my $s_' . $n2;
if (length($dfl))
{
$decl .= '|' . $dfl . '| # ';
}
else
{
$decl .= ';| | # ';
}
if (exists($args->{short}))
{
$decl .= $args->{short};
}
$decl .= "\n";
}
my $itmlst = tabalignstr($decl);
my $optlist = tabalignstr($getoptarg);
$pipespecial = quotemeta($pipespecial);
$getoptarg = join("\n", @{$optlist});
# fix the pipe character
$getoptarg =~ s/$pipespecial/\|/gm;
my $setglob = "";
$setglob .=
'pod2usage(-msg => $glob_id, -exitstatus => 1) if $s_help;' . "\n"
if ($gothelp);
$setglob .=
'pod2usage(-msg => $glob_id, -exitstatus => 0, -verbose => 2) if $s_man;' . "\n"
if ($gotman);
$setglob .= "\n" if ($gotman||$gothelp);
$setglob .= "\n" . '$glob_glob' . " = {};\n\n";
# store the properties of the in the glob
if (exists($bigh->{version}) ||
exists($bigh->{properties}))
{
$setglob .= "\n# version and properties from json definition";
$setglob .= "\n" . '$glob_glob->{_sleazy_properties}' . " = {};";
$setglob .= "\n" . '$glob_glob->{_sleazy_properties}->{version}' .
' = \'' . $bigh->{version} . '\';'
if (exists($bigh->{version}));
if (exists($bigh->{properties}))
{
for my $kk (sort(keys(%{$bigh->{properties}})))
{
my $vv = $bigh->{properties}->{$kk};
$setglob .= "\n" . '$glob_glob->{_sleazy_properties}->{' .
$kk . '}' .
' = \'' . $vv . '\';'
unless (ref($vv)); # XXX XXX: no references for now
}
}
$setglob .= "\n" .
'$glob_glob->{_sleazy_properties}->{slzy_argv_str} = $slzy_argv_str;';
$setglob .= "\n\n";
}
if (length($validator))
{
my $v2 = tabalignstr($validator);
$setglob .= join("\n", @{$v2});
$setglob .= "\n";
$setglob .= "\n";
}
my $sg2 = tabalignstr($globset);
$setglob .= join("\n", @{$sg2});
$setglob .= "\n\nglob_validate();\n";
my $bigstr = "\n" .
"# WARNING: DO NOT MODIFY THE FOLLOWING SECTION:\n" .
"# Generated by " . basename($0) . " version " .
$glob_glob->{_sleazy_properties}->{version} .
((exists($glob_glob->{_sleazy_properties}->{slzy_date})) ?
" (release " .
localtime($glob_glob->{_sleazy_properties}->{slzy_date}) .
")" : "" ) .
"\n" .
"# Make any changes under SLZY_TOP_BEGIN/SLZY_LONG_BEGIN\n" .
"# Any additional validation logic belongs in glob_validate()\n" .
"\n" .
perl_getopt_func();
$cmdline =
doformat($bigstr,
{
VARLIST => join("\n", @{$itmlst}),
GETOPTVARLIST => $getoptarg,
SETGLOB => $setglob
}
);
return [$oldcmdline, $cmdline];
} # end sleazify_cmdline
sub sleazify_long_strings
{
my ($lstr, $bigh, $filnam) = @_;
my $all_long_str = {};
return
unless (defined($lstr) && length($lstr));
my @lines = split(/\n/, $lstr);
my $gotone;
my $gotEOF;
my $ll;
# build a hash of all named long strings
for my $lin (@lines)
{
if ($gotone)
{
# if found matching EOF for HERE doc then finish the string
if ($lin =~ m/$gotEOF/)
{
$all_long_str->{$gotone} = join("\n", @{$ll});
undef $gotone;
undef $gotEOF;
}
else # keep adding string pieces to temp array
{
push @{$ll}, $lin;
}
}
else
{
# look for the beginning of a HERE document, eg:
# my $foo = <<'fooEOF';
if ($lin =~ m/^\s*my\s+\$(.*)\s*\=\s*\<\<\s*\'(.*)\'\;/)
{
my @foo =
($lin =~ m/^\s*my\s+\$(.*)\s*\=\s*\<\<\s*\'(.*)\'\;/);
die "bad long string $lin" unless (2 == scalar(@foo));
$gotone = shift @foo;
$gotone =~ s/\s*$//; # remove trailing spaces.
$gotEOF = quotemeta(shift @foo);
$ll = []; # new temp array
}
}
}
while (my ($kk, $vv) = each(%{$all_long_str}))
{
$all_long_str->{$kk} = doformat($vv,
{
HEAD1 => "=head1",
HEAD2 => "=head2",
PODOVER8 => "=over 8",
PODBACK => "=back",
PODCUT => "=cut",
ITEM => "=item",
});
}
$bigh->{all_long_strings} = $all_long_str;
# see if "long" description is just a "$token" for a matching long string
if (exists($bigh->{long}) &&
($bigh->{long} =~ m/^\$/))
{
my $lkey = $bigh->{long};
$lkey =~ s/^\$//; # remove leading $
# substitute the long string
$bigh->{long} = $all_long_str->{$lkey}
if (exists($all_long_str->{$lkey}));
}
if (exists($bigh->{args}))
{
for my $arg (@{$bigh->{args}})
{
if (exists($arg->{long}) &&
($arg->{long} =~ m/^\$/))
{
my $lkey = $arg->{long};
$lkey =~ s/^\$//; # remove leading $
# substitute the long string
$arg->{long} = $all_long_str->{$lkey}
if (exists($all_long_str->{$lkey}));
}
}
}
# print Data::Dumper->Dump([$bigh]);
} # end sleazify_long_strings
sub get_derived_properties
{
my $allprops = shift;
$allprops = {}
unless (defined($allprops));
my ($progoptions, $copyholder, $copydates, $authorname, $bugemail);
$progoptions = "";
if (exists($allprops->{AUTHORNAME}))
{
$authorname = $allprops->{AUTHORNAME};
$bugemail =
(exists($allprops->{BUGEMAIL})) ?
$allprops->{BUGEMAIL} :
"Address bug reports and comments to: " . getlogin();
}
else
{
$authorname = getlogin();
$bugemail =
(exists($allprops->{BUGEMAIL})) ?
$allprops->{BUGEMAIL} :
"Address bug reports and comments to: $authorname";
# get the real name from the login name
{
my @fff = getpwnam($authorname);
$authorname = $fff[6]
if (scalar(@fff) > 6);
}
$allprops->{AUTHORNAME} = $authorname;
$allprops->{BUGEMAIL} = $bugemail
unless (exists($allprops->{BUGEMAIL}));
}
if (exists($allprops->{COPYDATES}))
{
$copydates = $allprops->{COPYDATES};
}
else # use current year for copydate unless specified
{
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime();
$copydates = $year += 1900;
$allprops->{COPYDATES} = $copydates;
}
# copyright holder defaults to author
if (exists($allprops->{COPYHOLDER}))
{
$copyholder = $allprops->{COPYHOLDER};
}
else
{
$allprops->{COPYHOLDER} = $authorname;
$copyholder = $allprops->{COPYHOLDER};
}
return ($progoptions, $copyholder, $copydates, $authorname, $bugemail)
} # end get_derived_properties
sub sleazify_podhdr
{
my ($oldpodhdr, $bigh, $filnam) = @_;
die "bad bigh for $oldpodhdr"
unless (defined($bigh) && exists($bigh->{short}));
my $podhdr = $oldpodhdr;
my $bigstr = perl_pod_header();
use File::Basename;
my $progname = basename($filnam);
my $shortoptlist = [];
my $longoptlist = [];
for my $args (@{$bigh->{args}})
{
my ($shrt, $lng, $otype);
$shrt = $args->{name};
my $reqarg = (exists($args->{required}) && $args->{required});
$shrt = $args->{short} if (exists($args->{short}));
$lng = $shrt;
$lng = $args->{long} if (exists($args->{long}));
$otype = "";
if (exists($args->{type}))
{
# allow file (input file) or outfile (output file)
$otype .= " <filename>" if ($args->{type} =~ m/^(file|outfile)/i);
}
$otype .= " (Required)" if ($reqarg);
push @{$shortoptlist}, '|-' . $args->{name} . '|' . $shrt;
push @{$longoptlist}, '=item B<-' . $args->{name} . '>' . $otype .
"\n\n" .
# # offset for short strings, long strings are ok
# ((length($lng) < 72) ? $glob_glob2->{tabstr} : "" ) .
$glob_glob2->{tabstr} .
$lng . "\n";
}
my $itmlst = tabalignstr(join("\n", @{$shortoptlist}));
my %allprops;
if (exists($bigh->{properties}))
{
while (my ($kk, $vv) = each(%{$bigh->{properties}}))
{
# print "$kk: $vv\n";
$allprops{$kk} = $vv;
}
}
my ($progoptions, $copyholder, $copydates, $authorname, $bugemail) =
get_derived_properties(\%allprops);
my $basicargs =
{
PROGNAME => $progname,
SHORTDESCRIPTION => $bigh->{short},
LONGDESCRIPTION => $bigh->{long},
HEAD1 => "=head1",
HEAD2 => "=head2",
PODOVER8 => "=over 8",
PODBACK => "=back",
PODCUT => "=cut",
ITEM => "=item",
OPTIONS => join("\n", @{$itmlst}),
PODITEMS => join("\n", @{$longoptlist}),
PROGOPTIONS => $progoptions,
COPYHOLDER => $copyholder,
COPYDATES => $copydates,
AUTHORNAME => $authorname,
BUGEMAIL => $bugemail
};
my $docversion = "\n";
$basicargs->{DOCVERSION} = $docversion;
# generate a version entry
if (exists($bigh->{version}))
{
$basicargs->{VERSION} = $bigh->{version};
$basicargs->{DOCDATE} = localtime();
$docversion =
doformat(
perl_pod_docversion(),
$basicargs
);
$basicargs->{DOCVERSION} = $docversion;
}
$podhdr = "\n" .
"# WARNING: DO NOT MODIFY THE FOLLOWING POD DOCUMENT:\n" .
"# Generated by " . basename($0) . " version " .
$glob_glob->{_sleazy_properties}->{version} .
((exists($glob_glob->{_sleazy_properties}->{slzy_date})) ?
" (release " .
localtime($glob_glob->{_sleazy_properties}->{slzy_date}) .
")" : "" ) .
"\n" .
"# Make any changes under SLZY_TOP_BEGIN/SLZY_LONG_BEGIN\n" .
"\n" .
doformat($bigstr,
$basicargs
);
return [$oldpodhdr, $podhdr];
} # end sleazify_podhdr
sub sleazify_topstr
{
my $oldtopstr = shift;
my $topstr = $oldtopstr;
my %abbrev = (
's' => "short",
'l' => "long",
'n' => "name",
't' => "type",
'vz' => "version"
);
for my $kk (keys(%abbrev))
{
if ($topstr =~ m/^\s*$kk\s*\:/ms)
{
$topstr =~ s/(^\s*)($kk\s*\:)/$1\"$abbrev{$kk}\" :/gms;
}
}
if ($topstr =~ m/^\s*a\s*\:\s*\[/ms)
{
$topstr =~ s/(^\s*)(a\s*\:\s*\[)/$1\"args\" : \[/gms;
}
if ($topstr =~ m/^\s*a\s*\:\s*\w+/ms)
{
$topstr =~ s/(^\s*)(a\s*\:\s*)(\w+)/$1\"alias\" : $3/gms;
}
my @baz = split(/\n/, $topstr);
my $expandedargs = 0;
my @zzz;
for my $lin (@baz)
{
if ($lin !~ m/\s*\"args\"\s*\:\s*\[.*\]/)
{
push @zzz, $lin;
next;
}
my @bbb = ($lin =~ m/(\s*\"args\"\s*:\s*\[)\s*(.*)\s*\]/);
die "bad arg list: $lin" unless (2 == scalar(@bbb));
# track if expanded arg list from single line to multiline
$expandedargs = 1;
my $apref = shift @bbb;
push @zzz, $apref;
my $argl = shift @bbb;
my @rawargs = split(/\,/, $argl);
# print Data::Dumper->Dump(\@rawargs);
my @allargs;
for my $a2 (@rawargs)
{
$a2 =~ s/^\s*//;
$a2 =~ s/\s*$//;
if ($a2 !~ /\:/)
{
push @zzz,
" " x (length($apref)+1) .
"{\n" .
" " x (length($apref)+2) .
'"name" : ' . $a2 . "\n" .
" " x (length($apref)+2) .
'"type" : u ' . "\n" .
" " x (length($apref)+2) .
"}";
next;
}
my @uuu = split(/\:/, $a2, 2);
die "bad arg val in $lin" unless (2 == scalar(@uuu));
$a2 = shift @uuu;
my $atyp = shift @uuu;
push @zzz,
" " x (length($apref)+1) .
"{\n" .
" " x (length($apref)+2) .
'"name" : ' . $a2 . "\n" .
" " x (length($apref)+2) .
'"type" : ' . $atyp . "\n" .
" " x (length($apref)+2) .
"}";
}
push @zzz,
" " x (length($apref)) . "]";
} # end for my $lin
# rebuild the string with expanded arguments
$topstr = join("\n", @zzz);
@baz = split(/\n/, $topstr);
for my $ii (1..(scalar(@baz)-1))
{
# see if need commas or quoting
my $curr = $baz[$ii];
if ($curr =~ m/^\s*\"\w+\"\s\:\s*\w+/)
{
my $savecomma = ($curr =~ m/\,\s*$/);
$curr =~ s/\s*\,\s*$//;
my @ppp = split(/\:/, $curr, 2);
die "bad line: $curr" unless (2 == scalar(@ppp));
my $p2 = $ppp[1];
$p2 =~ s/^\s*//;
$p2 =~ s/\s*$//;
$p2 = '"' . $p2 . '"'
unless ($p2 =~ m/\".*\"/);
$curr = $ppp[0] . ": " . $p2;
$curr .= "," if ($savecomma);
}
$baz[$ii] = $curr;
if ($baz[$ii] !~ m/(^\s*\"\w+\"\s\:)|(^\s*(\{|\[))/)
{
# no comma needed
my $prev = $baz[$ii-1];
$prev =~ s/\s*$//; # trim trailing spaces
# trim final comma if it exists
$prev =~ s/\s*\,\s*$//;
L_fixp2:
$baz[$ii-1] = $prev;
}
else
{
my $prev = $baz[$ii-1];
$prev =~ s/\s*$//; # trim trailing spaces
# trim space between final quote and comma if it exists
$prev =~ s/\"\s*\,\s*$/\"\,/;
# no comma if previous is open brace
goto L_fixprev if ($prev =~ m/\{|\[$/);
$prev =~ s/\}/\}\,/
if ($prev =~ m/^\s*\}$/);
$prev =~ s/\]/\]\,/
if ($prev =~ m/^\s*\]$/);
goto L_fixprev if ($prev =~ m/^\s*\"\w+\"\s\:\s*\".*\"\s*\,/);
if ($prev =~ m/^\s*\"\w+\"\s\:/)
{
$prev =~ s/\,$//;
my @ppp = split(/\:/, $prev, 2);
die "bad line: $prev" unless (2 == scalar(@ppp));
my $p2 = $ppp[1];
$p2 =~ s/^\s*//;
$p2 =~ s/\s*$//;
$p2 = '"' . $p2 . '"'
unless ($p2 =~ m/\".*\"/);
$prev = $ppp[0] . ": " . $p2 . ",";
}
L_fixprev:
$baz[$ii-1] = $prev;
}
} # end for ii
while (1)
{
my $a5 = shift @baz;
last if ($a5 =~ m/EOF_bigstr/);
}
while (1)
{
my $a5 = pop @baz;
last if ($a5 =~ m/EOF_bigstr/);
}
$topstr = join("\n", @baz);
my $helpj =
'{
"name" : "help",
"alias" : "?",
"long" : "Print a brief help message and exits.",
"short" : "brief help message",
"type" : "untyped",
"required" : "0"
}';
my $manj =
'{
"name" : "man",
"long" : "Prints the manual page and exits.",
"short" : "full documentation",
"type" : "untyped",
"required" : "0"
}';
my $bigh = JSON::from_json($topstr);
$bigh->{args} = [] unless (exists($bigh->{args}));
$bigh->{short} = "" unless (exists($bigh->{short}));
$bigh->{long} = $bigh->{short} unless (exists($bigh->{long}));
$bigh->{version} = "0" unless (exists($bigh->{version}));
$bigh->{properties} = {} unless (exists($bigh->{properties}));
# store date that file was regenerated
$bigh->{properties}->{slzy_date} = time();
# save initial properties
if (1)
{
my $allproph = {};
# load "allproperties" with specified properties from json
while (my ($kk, $vv) = each(%{$bigh->{properties}}))
{
# skip some volatile properties
next if ($kk =~ m/^(slzy\_date|slzy\_argv\_str|version)$/);
$allproph->{$kk} = $vv;
}
# reload default properties and "-define" properties according
# to precedence
load_properties($allproph);
# get the "derived" properties
my ($progoptions, $copyholder, $copydates, $authorname, $bugemail) =
get_derived_properties($allproph);
# update the bigh properties
while (my ($kk, $vv) = each(%{$allproph}))
{
# skip some volatile properties
next if ($kk =~ m/^(slzy\_date|slzy\_argv\_str|version)$/);
$bigh->{properties}->{$kk} = $vv;
}
}
# increment the version if specified
if (exists($glob_glob->{incversion}) &&
$glob_glob->{incversion})
{
# must be integer
if ($bigh->{version} =~ m/^\d+$/)
{
$bigh->{version} += 1;
}
}
if ($expandedargs)
{
# add help and man
unshift @{$bigh->{args}}, JSON::from_json($manj);
unshift @{$bigh->{args}}, JSON::from_json($helpj);
}
$topstr = JSON::to_json($bigh,
{pretty => 1, indent => 2,
canonical => 1});
# rebuild topstr
$topstr = "\nif (0)\n{\n" .
' my $bigstr = <<\'EOF_bigstr\';' . "\n" .
$topstr .
"\nEOF_bigstr\n}\n";
return [$oldtopstr, $topstr, $bigh];
} # end sleazify_topstr
sub sleazify
{
my $filnam = shift;
my $whole_file;
{
# $$$ $$$ undefine input record separator (\n)
# and slurp entire file into variable
local $/;
undef $/;
my $fh;
open $fh, "< $filnam" or die "cannot open $filnam: $!";
$whole_file = <$fh>;
close $fh;
}
my $prefx = quotemeta('SLZY_TOP_BEGIN');
my $suffx = quotemeta('SLZY_TOP_END');
my @foo = ($whole_file =~ m/^\s*\#\s*$prefx\s*$(.*)^\s*\#\s*$suffx\s*$/ms);
return
unless (scalar(@foo));
my $topfoo = sleazify_topstr($foo[0]);
# print Data::Dumper->Dump($topfoo);
my $oldtopstr = shift (@{$topfoo});
my $topstr = shift (@{$topfoo});
my $bigh = shift (@{$topfoo});
$oldtopstr = quotemeta($oldtopstr);
$whole_file =~ s/$oldtopstr/$topstr/gms;
$prefx = quotemeta('SLZY_LONG_BEGIN');
$suffx = quotemeta('SLZY_LONG_END');
@foo = ($whole_file =~ m/^\s*\#\s*$prefx\s*$(.*)^\s*\#\s*$suffx\s*$/ms);
sleazify_long_strings($foo[0], $bigh, $filnam)
if (scalar(@foo));
$prefx = quotemeta('SLZY_POD_HDR_BEGIN');
$suffx = quotemeta('SLZY_POD_HDR_END');
@foo = ($whole_file =~ m/^\s*\#\s*$prefx\s*$(.*)^\s*\#\s*$suffx\s*$/ms);
return
unless (scalar(@foo));
my $podhdrfoo = sleazify_podhdr($foo[0], $bigh, $filnam);
my $oldpodhdr = shift (@{$podhdrfoo});
my $podhdr = shift (@{$podhdrfoo});
$oldpodhdr = quotemeta($oldpodhdr);
$whole_file =~ s/$oldpodhdr/$podhdr/gms;
$prefx = quotemeta('SLZY_CMDLINE_BEGIN');
$suffx = quotemeta('SLZY_CMDLINE_END');
@foo = ($whole_file =~ m/^\s*\#\s*$prefx\s*$(.*)^\s*\#\s*$suffx\s*$/ms);
return
unless (scalar(@foo));
my $cmdlinefoo = sleazify_cmdline($foo[0], $bigh);
my $oldcmdline = shift (@{$cmdlinefoo});
my $cmdline = shift (@{$cmdlinefoo});
$oldcmdline = quotemeta($oldcmdline);
$whole_file =~ s/$oldcmdline/$cmdline/gms;
my $outi;
my $outfname = $filnam . ".slzy";
open $outi, "> $outfname" or die "cannot open $outfname: $!";
print $outi $whole_file;
close $outi;
}
if (1)
{
if (exists($glob_glob->{showproperties}) &&
$glob_glob->{showproperties})
{
if (exists($glob_glob->{_sleazy_properties}))
{
my $propstr = JSON::to_json($glob_glob->{_sleazy_properties},
{pretty => 1, indent => 2,
canonical => 1});
print $propstr, "\n";
}
exit(0);
}
if (exists($glob_glob->{maketemplate}) &&
$glob_glob->{maketemplate})
{
my ($progoptions, $copyholder, $copydates, $authorname, $bugemail) =
get_derived_properties();
print doformat(
sleazy_perl_template(),
{
SLZY => "SLZY_",
PROGOPTIONS => $progoptions,
COPYHOLDER => $copyholder,
COPYDATES => $copydates,
AUTHORNAME => $authorname,
BUGEMAIL => $bugemail
}
);
exit(0);
}
for my $filnam (@ARGV)
{
sleazify($filnam);
}
}
# SLZY_TOP_BEGIN
if (0)
{
my $bigstr = <<'EOF_bigstr';
{
"args" : [
{
"alias" : "?",
"long" : "Print a brief help message and exits.",
"name" : "help",
"required" : "0",
"short" : "brief help message",
"type" : "untyped"
},
{
"long" : "Prints the manual page and exits.",
"name" : "man",
"required" : "0",
"short" : "full documentation",
"type" : "untyped"
},
{
"long" : "$deflong",
"name" : "define",
"short" : "define a general property",
"type" : "string%"
},
{
"name" : "dbg"
},
{
"alias" : "showprops|showproperty",
"name" : "showproperties",
"short" : "print out property definitions",
"type" : "unknown"
},
{
"name" : "incversion",
"short" : "increment version number"
},
{
"alias" : "template|tmpl",
"long" : "$tmpllong",
"name" : "maketemplate",
"short" : "make a sleazy template"
}
],
"long" : "$toplong",
"properties" : {
"AUTHORNAME" : "Jeffrey I Cohen",
"BUGEMAIL" : "Address bug reports and comments to: jcohen@greenplum.com",
"COPYDATES" : "2012, 2013",
"COPYHOLDER" : "Greenplum",
"slzy_date" : 1360011781
},
"short" : "an easy way to go",
"version" : "9"
}
EOF_bigstr
}
# SLZY_TOP_END
# SLZY_LONG_BEGIN
if (0)
{
my $toplong = <<'EOF_longstr';
sleazy uses templates to construct programs and documentation. The
program is defined using a JSON data structure stored in a HERE
document in the SLZY_TOP_BEGIN/END block. The JSON doc describes the
program arguments, their names and types, and provides basic
documentation. Use sleazy.pl to convert your program template into
actual code.
{HEAD2} JSON doc
sleazy can convert a tiny program description into
grammatically-correct JSON. For example, the spec:
n: my name is foo
gets converted to
"name" : "my name is foo"
The top-level fields are:
{PODOVER8}
{ITEM} short (abbreviation "s")
The short description of the program.
{ITEM} long (abbreviation "l")
The long description of the program. For readability, you can
construct the long description as a separate HERE doc in the
SLZY_LONG_BEGIN/END block, and use the variable name instead, eg:
"long" : "$longdesc"
will pick up the long description "my $longdesc" from SLZY_LONG_BEGIN
{ITEM} args (abbreviation "a")
An array of arguments. The easiest spec is a single-line array of
comma-separated argument names, eg:
a: [argname1, argname2, argname3]
becomes:
"args" : [
{
"name" : "argname1",
"type" : "u"
},
{
"name" : "argname2",
"type" : "u"
},
{
"name" : "argname3",
"type" : "u"
}
{ITEM} version (abbreviation "vz")
If version is not specified, the program is labelled as version 0.
{ITEM} properties (no abbreviation)
Properties can contain a series of scalar values for various program
properties, eg the AUTHORNAME for the author or COPYDATES for
copyright dates. By default it contains the slzy_date, the time that
the program was last regenerated.
When a new program is generated, the basic properties (eg AUTHORNAME,
COPYDATES) are derived from the user environment, or taken the from
HOME/sleazyprop.json file (if it exists). You can override these
settings with an explicit "-define" option on the command line, eg:
sleazy.pl -define AUTHORNAME="Thomas Jefferson" constitution.pl
will reset the author of constitution.pl to Thomas Jefferson.
{PODBACK}
{HEAD1} Usage
After you update JSON description, you must run sleazy.pl to
regenerate the target file. Note that sleazy.pl does not overwrite
the input file. Instead, it generates an updated version of the file
with a .slzy extension, ie:
{PODOVER8}
perl sleazy.pl foo.pl
{PODBACK}
creates an updated foo.pl.slzy file. The user must manually replace
the existing .pl file.
{HEAD2} sleazyprop.json
You can set default properties in sleazyprop.json in your home
directory. The format of this document is the same as the output of
the "-showproperties" command. Typical settings are the AUTHORNAME,
BUGEMAIL address, and COPYHOLDER (copyright holder). You can override
these properties using "-define" command-line settings.
{HEAD1} Argument Types
sleazy.pl distinguishes between "typed" and "untyped" arguments. An
"untyped" argument is just a flag that is set (or unset). A "typed"
argument takes a value that immediately follows the named flag (either
"-argname argval" or "-argname=argval" will work).
The argument types are:
{PODOVER8}
{ITEM} untyped (default)
Not typed.
{ITEM} string
a string.
{ITEM} int
An integer. (non-integer values are mysteriously set to zero).
{ITEM} file
An existing file -- if the file is non-existent or inaccessible the
program will error out. If you wish to specify a filename for a new
file use "outfile".
{ITEM} outfile
An output file. No existence check is performed.
{PODBACK}
{HEAD2} Argument Type Options
Normally, arguments are scalar attributes of the glob_glob hash, eg
"-name=value" results in a setting of glob_glob->{name}="value", and
multiple settings of the same flag result in the last setting taking
precedence. To allow multiple specifications of an argument, the
argument types optionally take an array or hash suffix, eg "string%"
allows for a hash of strings, or use "string[]" or "string@" for an
array.
{HEAD1} CAVEATS/Future Work
Perl Getopt::Long and sleazy distinguish "required" and "optional"
arguments slightly differently. For starters, sleazy refers to them
as "arguments", and Getopt::Long calls them "options". The sleazy
"argument name" is the Getopt command-line flag for an option. But it
is so much easier to talk about optional arguments versus optional
options. For sleazy, if an argument is "untyped", then it does not
take a value, and it can only be optional -- that is, the flag is set
or unset. If an argument is typed, then the command-line flag is
always followed by a value, and the "flag plus value" can be optional
or required. GetOpt::Long uses "required" and "optional" to
distinguish whether a flag must be followed by a value, not whether
the flag itself is required or optional. We may want to approach this
by adding the concept of default values with a "set" and "unset"
context. If the flag is not specified, then the "unset" default is
used. If the flag is set, but no value is supplied, then the "set"
default is used. If the flag is set and an argument value is supplied
then that value is used.
EOF_longstr
my $tmpllong = <<'EOF_tmpll';
Generate a sleazy template for a program. You supply the rest.
EOF_tmpll
my $deflong = <<'EOF_deflong';
Define a general property of the form key=value. Note that
multiple definitions are possible, eg:
--define AUTHORNAME="joe tool" --define COPYDATES="2010,2011"
EOF_deflong
}
# SLZY_LONG_END