+++ /dev/null
-#! perl -w
-
-# This scripts finds calls of printf and printf-like functions which
-# do not use a literal string as format. Such calls are potentially
-# dangerous as they could use formats which do not match their
-# argument lists.
-
-use strict;
-use File::Find;
-no warnings 'File::Find';
-
-my @FUNCTIONS =
- (
- # NAME ........ name of function
- # FORMATPOS ... index of format string argument, first is 1
- {NAME => 'printf' ,FORMATPOS => 1},
- {NAME => 'sprintf' ,FORMATPOS => 2},
- {NAME => 'fprintf' ,FORMATPOS => 2},
- {NAME => 'error' ,FORMATPOS => 1},
- {NAME => 'dolog' ,FORMATPOS => 1},
- {NAME => 'dolog_plain',FORMATPOS => 1},
- );
-
-my $rxall;
-my %tests;
-my @tests;
-my @files;
-
-prepare();
-find(\&wanted,'.');
-process();
-
-sub prepare
-{
- for my $f (@FUNCTIONS) {
- my $name = $f->{NAME};
- $rxall .= "|" if $rxall;
- $rxall .= "\\b$name\\b";
-# push @{$tests{$f->{FORMATPOS}}},$f;
- $tests{$f->{NAME}} = $f;
- }
- $rxall = qr/($rxall)/;
- study $rxall;
-}
-
-sub wanted
-{
- push @files, $File::Find::name if /\.[ch]$/i;
- push @files, $File::Find::name if /\.inc$/i;
-}
-
-sub get_args
-{
- my ($coderef,$file,$line) = @_;
- my $arg;
- my $level = 0;
- my @args;
-
- ARG:
- while (1) {
- unless ($$coderef =~ /\G(.*?)([,()"])/g) {
- return undef;
- }
- $arg .= $1;
- my $d = $2;
- if ($d eq ')') {
- if ($level-- == 0) {
- push @args,$arg;
- return \@args;
- }
- }
- elsif ($d eq ',') {
- if ($level == 0) {
- push @args,$arg;
- $arg = '';
- next ARG;
- }
- }
- elsif ($d eq '(') {
- $level++;
- }
- elsif ($d eq '"') {
- unless($$coderef =~ /\G ( ([^\\"]|\\.)* " ) /gx) {
- return undef;
- }
- $d .= $1;
- }
- $arg .= $d;
- }
-}
-
-sub process
-{
- for my $file (@files) {
-# print "$file\n";
- open(FILE,"<$file") or die "Could not open $file: $!";
- my $code;
- my $pos = 0;
- my @pos;
- while (<FILE>) {
- s/\n/ /;
- s/[ \t]+/ /;
- $code .= $_;
- push @pos,$pos;
- $pos += length;
- }
- close(FILE);
-
- my $line = 1;
- OCC:
- while ($code =~ /$rxall/g) {
- my $pos = pos($code);
- my $fname = $1;
- my $test = $tests{$fname};
- while (pos($code) > $pos[$line]) {$line++}
-# print "$1\n";
- unless ($code =~ /\G\s*\(/g) {
- print STDERR "$file:$line: warning: could not find parenthesis\n";
- pos($code) = $pos;
- next OCC;
- }
-
- my $index = 1;
-
- my $args = get_args(\$code,$file,$line);
- unless ($args) {
- print STDERR "$file:$line:warning: could not parse arguments\n";
- pos($code) = $pos;
- next OCC;
- }
-
- if (@$args < $test->{FORMATPOS}) {
- print STDERR "$file:$line: warning: could not find format of $fname\n";
- next OCC;
- }
-
- my $fmt = $args->[$test->{FORMATPOS} - 1];
-
- if ($fmt =~ /^\s*$/) {
- print "$file:$line: missing format: $fname(".join(',',@$args).")\n";
- next OCC;
- }
-
- unless ($fmt =~ /^\s*"/) {
- print "$file:$line: nonliteral format: $fname(".join(',',@$args).")\n";
- next OCC;
- }
-
- if ($fmt =~ /^\s*"(.*)"\s*$/) {
- my $f = $1;
- $f =~ s/"\s+"//g;
- my $pct = 0;
- while ($f =~ /(%%?)/g) {$pct++ if length($1)==1};
-
- if ($pct != @$args - $test->{FORMATPOS}) {
- print "$file:$line: arguments?: $fname(".join(',',@$args).")\n";
- }
- }
- }
- }
-}
-