interchange-cvs at icdevgroup
May 6, 2008, 10:12 PM
Post #3 of 4
(154 views)
Permalink
|
User: jon
Date: 2008-05-07 05:12:04 GMT
Modified: . MANIFEST WHATSNEW-5.5
Added: eg iclint
Log:
Add new iclint tool for checking ITL syntax (roughly).
By Greg Sabino Mullane.
Revision Changes Path
2.226 interchange/MANIFEST
rev 2.226, prev_rev 2.225
Index: MANIFEST
===================================================================
RCS file: /var/cvs/interchange/MANIFEST,v
retrieving revision 2.225
retrieving revision 2.226
diff -u -u -r2.225 -r2.226
--- MANIFEST 7 May 2008 03:57:32 -0000 2.225
+++ MANIFEST 7 May 2008 05:12:04 -0000 2.226
@@ -1010,6 +1010,7 @@
eg/cvv2.svg
eg/filter/calculated.filter
eg/gpg_display
+eg/iclint
eg/ifdef
eg/merge-tab-files
eg/news_feature/dbconf/default_db/news.dbm
1.116 interchange/WHATSNEW-5.5
rev 1.116, prev_rev 1.115
Index: WHATSNEW-5.5
===================================================================
RCS file: /var/cvs/interchange/WHATSNEW-5.5,v
retrieving revision 1.115
retrieving revision 1.116
diff -u -u -r1.115 -r1.116
--- WHATSNEW-5.5 6 May 2008 17:12:18 -0000 1.115
+++ WHATSNEW-5.5 7 May 2008 05:12:04 -0000 1.116
@@ -19,6 +19,8 @@
Extra tools
-----------
+* Added new eg/iclint tool for quick-and-dirty ITL syntax checking.
+
* Improved eg/check_perl_itl error detection.
1.1 interchange/eg/iclint
rev 1.1, prev_rev 1.0
Index: iclint
===================================================================
#!/usr/bin/perl -- -*-cperl-*-
## Check an interchange file for problems.
## Greg Sabino Mullane, greg[at]endpoint.com
## Created because Greg often uses [if foobar] instead of [if scratch foobar]...
## Add stuff to the DATA section as you find it...
use strict;
use warnings;
use Data::Dumper;
use Getopt::Long;
my $VERSION = '1.0.4';
## Set the default arguments
my $icarg =
{
verbose => 0,
dietag => 0,
warntagonce => 0,
errorexit => 1,
};
GetOptions
($icarg,
'verbose=i',
'dietag=i',
'warntagonce=i',
'errorexit=i',
'help',
);
help() if ! @ARGV or $icarg->{help};
sub help {
warn qq{Usage: $0 [args] file1 [file2 file3 ...]
verbose -- detailed output (default=0)
dietag -- die on unknown tags (default=0)
warntagonce -- only show one warning per tag type (default=0)
errorexit -- exit as soon as a problem is found (default=1)
};
exit 1;
}
my $DIE_ON_UNKNOWN_TAG = $icarg->{dietag};
my $ONE_WARNING_PER_TAG = $icarg->{warntagonce};
my $DIE_ON_ERROR = $icarg->{errorexit};
my $VERBOSE = $icarg->{verbose};
my %error;
@ARGV or die qq{Usage: $0 file [file2 file3 ...]\n};
## Read in our tag information
my %tag;
while (<DATA>) {
next unless /^(\w[\w\-]+)\s*(.*)/;
my ($tag,$args) = ($1,$2);
exists $tag{lc $tag} and die qq{Oops - tag defined twice: $tag\n};
for my $arg (split /\s+/ => $args) {
if ($arg =~ /(\w+)=(.+)/) {
my ($c,$d) = ($1,$2);
$tag{lc $tag}{$c} = ($d =~ /,/ or $c eq 'validargs') ? {map {$_,1} split/,/ => $d} : $d;
}
else {
$tag{lc $tag}{$arg}++;
}
}
}
#die Dumper \%tag;
for my $file (@ARGV) {
open my $f, '<', $file or die qq{Could not open "$file": $!\n};
warn "Checking $file...\n";
my $slurp;
{ local $/; $slurp=<$f>; }
## Perl blocks often have comments inside of them, so empty them out first:
$slurp =~ s{(\[perl[^\]]*\]).*?(\[/perl\])}{$1$2}gsmi;
## Empty out all comments, perl, calc, and calcn blocks
$slurp =~ s{(\[comment[^\]]*\]).*?(\[/comment\])}{$1$2}gsmi;
$slurp =~ s{(\[perl[^\]]*\]).*?(\[/perl\])}{$1$2}gsmi;
$slurp =~ s{(\[calcn[^\]]*\]).*?(\[/calcn\])}{$1$2}gsmi;
$slurp =~ s{(\[calc[^n\]]*\]).*?(\[/calc\])}{$1$2}gsmi;
## Get temporary tags
while ($slurp =~ m{\[(?:query|loop)[^\]\[]+prefix=(\w+)}gsmi) {
my $prefix = $1;
if (exists $tag{$prefix} and ! exists $tag{$prefix}{prefix}) {
#error('query','prefix',qq{Bad prefix name used in query tag: "$prefix"});
}
$tag{$prefix}{prefix}=1;
}
## De-nest nested tags and parse them
1 while $slurp =~ s/(\[[^\]]+?)\[([^\]]+?)\]/&parse_tag($2); $1/gsme;
while ($slurp =~ /\[([^\]]+)\]/gsm) {
parse_tag($1);
}
## Any tags not add up?
for my $t (sort keys %tag) {
next unless $tag{$t}{close};
(!exists $tag{$t}{levels} or $tag{$t}{levels} == 0)
or error($t,'badlevel',qq{Bad number of levels: $tag{$t}{levels}});
}
close $f or warn qq{Could not close "$file": $!\n};
}
sub parse_tag {
my $section = shift;
## Collapse it into a single line
$section =~ s/[\n\r]/ /g;
## Is this a closing tag?
my $close = $section =~ s{^\s*/}{} ? 1 : 0;
## Grab the first word as the tag name
$section =~ s/^\s*(\w+)\s*// or die qq{Weird section: $section\n};
my $tag = lc $1;
$section =~ s/\s*$//;
$VERBOSE and printf "Checking tag $tag %s\n", exists $tag{$tag}{levels} ? $tag{$tag}{levels} : '';
## Do we know about this tag yet?
if (!exists $tag{$tag}) {
warn qq{Unknown tag "$tag"\n};
exit if $DIE_ON_UNKNOWN_TAG;
$tag{$tag}{unknown} = 1;
}
return if $tag{$tag}{unknown};
## If this is a named prefix, swap to prefix checking
if ($tag{$tag}{prefix}) {
$tag = 'prefix';
}
## If closeable, track opens and closes for a final count
if ($section !~ /^-/) {
if ($tag{$tag}{close}) {
$tag{$tag}{levels} += $close ? -1 : +1;
}
## If not closeable, yell if we see a closing tag for it
elsif ($close and !$tag{$tag}{closeok}) {
error($tag,'close',q{Closing tag is not allowed});
}
}
## From this point forward, ignore closing tags
return if $close;
## Check validargs if they exists
if ($tag{$tag}{validargs}) {
$section =~ /(\w+)/
or error($tag,'validargs',q{Arguments required, but not found}) and return;
my $arg = $1;
if (!exists $tag{$tag}{validargs}{$arg} and !exists $tag{$arg}{prefix}) {
error($tag,'validargs',qq{Invalid argument "$arg"});
return;
}
}
## Does it meet the minimum number of arguments?
my @words = split /\s+/ => $section;
my $words = @words;
if ($tag{$tag}{minargs}) {
$words >= $tag{$tag}{minargs}
or error($tag,'minargs',qq{Minimum number of arguments not reached: found $words, need $tag{$tag}{minargs}});
}
## Does it allow args at all (rare)
if ($tag{$tag}{noargs} and $words and $section !~ /^-/) {
error($tag,'noargs',qq{No arguments to tag allowed ($section)});
}
return;
} ## end of parsetag
sub error {
my ($tag,$type,$msg) = @_;
$error{$tag}{$type}++;
return if $ONE_WARNING_PER_TAG and $error{$tag}{$type} > 1;
warn qq{ERROR: Tag: "$tag" Problem: $msg\n};
exit if $DIE_ON_ERROR;
return;
} # end of error
__DATA__
## Lines starting with '#' like this one are skipped
## Format: TAGNAME ATTRIBS
## Case does not matter
## Possible attribs:
## close - tag must be closed explicitly
## validargs: list of valid first args, comma-separated
## minargs: minimum number of arguments inside of the tag
## noargs: no arguments are allowed
## closeok - may or may not need a closing tag (e.g. prefixes)
## Basic control
if close minargs=1 validargs=scratch,variable,cgi,type,value,items,session,item,discount,errors,explicit,sql,loop,config,inner,data,module,acclist,file,ordered
then close noargs
either close
else close
elsif close minargs=1 validargs=scratch,variable,cgi,type,value,items,session
unless close
condition close noargs
and minargs=1
or mt
## Blocks and variables
calc close noargs
calcn close xvalidargs=a,b
tmp close
tmpn close
perl close
sql close
scratch minargs=1
scratchd minargs=1
set close minargs=1
seti close minargs=1
cgi minargs=1
## Looping
loop close validargs=list,code,param,option,lr,pos,data,no,calc,filter,prefix,acclist,search,alternate,random
on-match close
no-match close
## Debugging
catch close minargs=1
comment close
dump mt
log close minargs=1 validargs=type
try close validargs=label minargs=1
## Jumping around
bounce validargs=page,href minargs=1
goto minargs=1 validargs=name,
## Shipping related
currency close
delivery validargs=shipmode,cutoff,extra_days,date minargs=1
fly-tax mt
handling mt
item close
quantity noargs
shipping mt
subtotal noargs
total mt
## HTML
area mt
button close minargs=2 validargs=name,text,src,form
form mt
image mt
page minargs=1
selected minargs=1
## Unsorted
assign validargs=clear,
banner close
control mt
convert close minargs=1 validargs=date,
convert_date close minargs=1 validargs=days,fmt
data minargs=2 validargs=session,table,base,products
display validargs=table,name
email close minargs=1 validargs=to,from,subject
error validargs=name,all,std_label,auto
filter close minargs=1
include minargs=1
label minargs=1
list close noargs
modifier close minargs=1
more noargs
no close noargs
process mt
query close
read minargs=1
setup noargs
table close
timed close
userdb minargs=1
value minargs=1
var minargs=1
## Special case:
prefix closeok minargs=1
## Local/unknown tags:
managed-content mt
fancy mt
cms mt
promo mt
city noclose
pagepop mt
map mt
cities close
uk mt
_______________________________________________
interchange-cvs mailing list
interchange-cvs[at]icdevgroup.org
http://www.icdevgroup.org/mailman/listinfo/interchange-cvs
|
