| #!/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 |
| |