diff options
Diffstat (limited to 'pkgtools/pkglint')
| -rw-r--r-- | pkgtools/pkglint/Makefile | 16 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/CVS_Entry.pm | 20 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/Change.pm | 20 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/FileUtil.pm | 167 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/Line.pm | 214 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/Logging.pm | 136 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/SimpleMatch.pm | 42 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/SubstContext.pm | 197 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/Type.pm | 102 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/Util.pm | 95 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/PkgLint/VarUseContext.pm | 69 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/build.pl | 25 | ||||
| -rw-r--r-- | pkgtools/pkglint/files/pkglint.pl | 1063 |
13 files changed, 1108 insertions, 1058 deletions
diff --git a/pkgtools/pkglint/Makefile b/pkgtools/pkglint/Makefile index a38dd5a0eb4..111e21a1185 100644 --- a/pkgtools/pkglint/Makefile +++ b/pkgtools/pkglint/Makefile @@ -1,4 +1,4 @@ -# $NetBSD: Makefile,v 1.424 2013/01/19 22:51:11 schmonz Exp $ +# $NetBSD: Makefile,v 1.425 2013/03/26 15:08:28 schmonz Exp $ # Note: if you update the version number, please have a look at the # changes between the CVS tag "pkglint_current" and HEAD. @@ -22,7 +22,6 @@ PKG_INSTALLATION_TYPES= overwrite pkgviews WRKSRC= ${WRKDIR} NO_CHECKSUM= yes -NO_BUILD= yes USE_LANGUAGES= # none AUTO_MKDIRS= yes @@ -30,8 +29,7 @@ AUTO_MKDIRS= yes SUBST_CLASSES+= pkglint SUBST_STAGE.pkglint= post-configure -SUBST_FILES.pkglint+= pkglint.pl pkglint.t -SUBST_FILES.pkglint+= plist-clash.pl +SUBST_FILES.pkglint+= build.pl pkglint.pl pkglint.t plist-clash.pl .if defined(BATCH) SUBST_SED.pkglint+= -e s\|@PKGSRCDIR@\|/usr/pkgsrc\|g .else @@ -49,10 +47,16 @@ SUBST_SED.pkglint+= -e s\|@DATADIR@\|${PREFIX}/share/pkglint\|g quick-install: ${RM} -rf ${WRKSRC} ${MKDIR} ${WRKSRC} - ${MAKE} do-extract subst-pkglint do-install selftest clean + ${MAKE} do-extract subst-pkglint do-build do-install selftest clean do-extract: - cd ${FILESDIR} && ${CP} pkglint.0 pkglint.1 pkglint.pl pkglint.t plist-clash.pl ${WRKSRC} + cd ${FILESDIR} && ${CP} build.pl pkglint.0 pkglint.1 pkglint.pl pkglint.t plist-clash.pl ${WRKSRC} + mkdir ${WRKSRC}/PkgLint + cd ${FILESDIR} && ${CP} PkgLint/*.pm ${WRKSRC}/PkgLint + +do-build: + cd ${WRKSRC} && ${PERL5} build.pl < pkglint.pl > pkglint.pl.inlined \ + && mv pkglint.pl.inlined pkglint.pl do-test: cd ${WRKSRC} && prove pkglint.t diff --git a/pkgtools/pkglint/files/PkgLint/CVS_Entry.pm b/pkgtools/pkglint/files/PkgLint/CVS_Entry.pm new file mode 100644 index 00000000000..8feb414951f --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/CVS_Entry.pm @@ -0,0 +1,20 @@ +package PkgLint::CVS_Entry; +#========================================================================== +# A CVS_Entry represents one line from a CVS/Entries file. +#========================================================================== + +use enum qw(FNAME REVISION MTIME TAG); + +sub new($$$$$) { + my ($class, $fname, $revision, $date, $tag) = @_; + my $self = [ $fname, $revision, $date, $tag ]; + bless($self, $class); + return $self; +} +sub fname($) { return shift()->[FNAME]; } +sub revision($) { return shift()->[REVISION]; } +sub mtime($) { return shift()->[MTIME]; } +sub tag($) { return shift()->[TAG]; } +#== End of PkgLint::CVS_Entry ============================================= + +1; diff --git a/pkgtools/pkglint/files/PkgLint/Change.pm b/pkgtools/pkglint/files/PkgLint/Change.pm new file mode 100644 index 00000000000..b68c5286d73 --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/Change.pm @@ -0,0 +1,20 @@ +package PkgLint::Change; +#========================================================================== +# A change entry from doc/CHANGES-* +#========================================================================== + +sub new($$$$$$) { + my ($class, $line, $action, $pkgpath, $version, $author, $date) = @_; + my $self = [ $line, $action, $pkgpath, $version, $author, $date ]; + bless($self, $class); + return $self; +} +sub line($) { return shift()->[0]; } +sub action($) { return shift()->[1]; } +sub pkgpath($) { return shift()->[2]; } +sub version($) { return shift()->[3]; } +sub author($) { return shift()->[4]; } +sub date($) { return shift()->[5]; } +#== End of PkgLint::Change ================================================ + +1; diff --git a/pkgtools/pkglint/files/PkgLint/FileUtil.pm b/pkgtools/pkglint/files/PkgLint/FileUtil.pm new file mode 100644 index 00000000000..ad7d1945396 --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/FileUtil.pm @@ -0,0 +1,167 @@ +package PkgLint::FileUtil; +#========================================================================== +# This package provides subroutines for loading and saving line-oriented +# files. The load_file() subroutine loads a file completely into memory, +# optionally handling continuation line folding. The load_lines() subrou- +# tine is an abbreviation for the common case of loading files without +# continuation lines. The save_autofix_changes() subroutine examines an +# array of lines if some of them have changed. It then saves the modified +# files. +#========================================================================== +use strict; +use warnings; + +BEGIN { + use Exporter; + use vars qw(@ISA @EXPORT_OK); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + load_file load_lines + save_autofix_changes + ); + + import PkgLint::Util qw( + false true + ); + import PkgLint::Logging qw( + NO_LINE_NUMBER + log_error log_note + ); +} + +sub load_physical_lines($) { + my ($fname) = @_; + my ($physlines, $line, $lineno); + + $physlines = []; + open(F, "< $fname") or return undef; + $lineno = 0; + while (defined($line = <F>)) { + $lineno++; + push(@{$physlines}, [$lineno, $line]); + } + close(F) or return undef; + return $physlines; +} + +sub get_logical_line($$$) { + my ($fname, $lines, $ref_lineno) = @_; + my ($value, $lineno, $first, $firstlineno, $lastlineno, $physlines); + + $value = ""; + $first = true; + $lineno = ${$ref_lineno}; + $firstlineno = $lines->[$lineno]->[0]; + $physlines = []; + + for (; $lineno <= $#{$lines}; $lineno++) { + if ($lines->[$lineno]->[1] =~ m"^([ \t]*)(.*?)([ \t]*)(\\?)\n?$") { + my ($indent, $text, $outdent, $cont) = ($1, $2, $3, $4); + + if ($first) { + $value .= $indent; + $first = false; + } + + $value .= $text; + push(@{$physlines}, $lines->[$lineno]); + + if ($cont eq "\\") { + $value .= " "; + } else { + $value .= $outdent; + last; + } + } + } + + if ($lineno > $#{$lines}) { + # The last line in the file is a continuation line + $lineno--; + } + $lastlineno = $lines->[$lineno]->[0]; + ${$ref_lineno} = $lineno + 1; + + return PkgLint::Line->new($fname, + $firstlineno == $lastlineno + ? $firstlineno + : "$firstlineno--$lastlineno", + $value, + $physlines); +} + +sub load_lines($$) { + my ($fname, $fold_backslash_lines) = @_; + my ($physlines, $seen_newline, $loglines); + + $physlines = load_physical_lines($fname); + if (!$physlines) { + return false; + } + + $seen_newline = true; + $loglines = []; + if ($fold_backslash_lines) { + for (my $lineno = 0; $lineno <= $#{$physlines}; ) { + push(@{$loglines}, get_logical_line($fname, $physlines, \$lineno)); + } + } else { + foreach my $physline (@{$physlines}) { + my $text = $physline->[1]; + + $text =~ s/\n$//; + push(@{$loglines}, PkgLint::Line->new($fname, $physline->[0], $text, [$physline])); + } + } + + if (0 <= $#{$physlines} && $physlines->[-1]->[1] !~ m"\n$") { + log_error($fname, $physlines->[-1]->[0], "File must end with a newline."); + } + + return $loglines; +} + +sub load_file($) { + my ($fname) = @_; + + return load_lines($fname, false); +} + +sub save_autofix_changes($) { + my ($lines) = @_; + + my (%changed, %physlines); + + foreach my $line (@{$lines}) { + if ($line->is_changed) { + $changed{$line->fname}++; + } + push(@{$physlines{$line->fname}}, @{$line->physlines}); + } + + foreach my $fname (sort(keys(%changed))) { + my $new = "${fname}.pkglint.tmp"; + + if (!open(F, ">", $new)) { + log_error($new, NO_LINE_NUMBER, "$!"); + next; + } + foreach my $physline (@{$physlines{$fname}}) { + print F ($physline->[1]); + } + if (!close(F)) { + log_error($new, NO_LINE_NUMBER, "$!"); + next; + } + + if (!rename($new, $fname)) { + log_error($fname, NO_LINE_NUMBER, "$!"); + next; + } + log_note($fname, NO_LINE_NUMBER, "Has been autofixed. Please re-run pkglint."); + } +} + +#== End of PkgLint::FileUtil ============================================== + +1; diff --git a/pkgtools/pkglint/files/PkgLint/Line.pm b/pkgtools/pkglint/files/PkgLint/Line.pm new file mode 100644 index 00000000000..a4b8e4720ea --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/Line.pm @@ -0,0 +1,214 @@ +#========================================================================== +# When files are read in by pkglint, they are interpreted in terms of +# lines. For Makefiles, line continuations are handled properly, allowing +# multiple physical lines to end in a single logical line. For other files +# there is a 1:1 translation. +# +# A difference between the physical and the logical lines is that the +# physical lines include the line end sequence, whereas the logical lines +# do not. +# +# A logical line is a class having the read-only fields C<file>, +# C<lines>, C<text>, C<physlines> and C<is_changed>, as well as some +# methods for printing diagnostics easily. +# +# Some other methods allow modification of the physical lines, but leave +# the logical line (the C<text>) untouched. These methods are used in the +# --autofix mode. +# +# A line can have some "extra" fields that allow the results of parsing to +# be saved under a name. +#========================================================================== +package PkgLint::Line; + +BEGIN { + import PkgLint::Util qw( + false true + assert + ); +} + +use enum qw(FNAME LINES TEXT PHYSLINES CHANGED BEFORE AFTER EXTRA); + +sub new($$$$) { + my ($class, $fname, $lines, $text, $physlines) = @_; + my ($self) = ([$fname, $lines, $text, $physlines, false, [], [], {}]); + bless($self, $class); + return $self; +} + +sub fname($) { return shift()->[FNAME]; } +sub lines($) { return shift()->[LINES]; } +sub text($) { return shift()->[TEXT]; } +# Note: physlines is _not_ a simple getter method. +sub is_changed($) { return shift()->[CHANGED]; } + +# querying, getting and setting the extra values. +sub has($$) { + my ($self, $name) = @_; + return exists($self->[EXTRA]->{$name}); +} +sub get($$) { + my ($self, $name) = @_; + assert(exists($self->[EXTRA]->{$name}), "Field ${name} does not exist."); + return $self->[EXTRA]->{$name}; +} +sub set($$$) { + my ($self, $name, $value) = @_; + assert(!exists($self->[EXTRA]->{$name}), "Field ${name} already exists."); + + # Make sure that the line does not become a cyclic data structure. + my $type = ref($value); + if ($type eq "") { + # ok + } elsif ($type eq "ARRAY") { + foreach my $element (@{$value}) { + my $element_type = ref($element); + assert($element_type eq "" || $element_type eq "PkgLint::SimpleMatch", + "Invalid array data type: name=${name}, type=${element_type}."); + } + } else { + assert(false, "Invalid data: name=${name}, value=${value}."); + } + + $self->[EXTRA]->{$name} = $value; +} + +sub physlines($) { + my ($self) = @_; + return [@{$self->[BEFORE]}, @{$self->[PHYSLINES]}, @{$self->[AFTER]}]; +} + +# Only for PkgLint::String support +sub substring($$$$) { + my ($self, $line, $start, $end) = @_; + + return substr($self->[PHYSLINES]->[$line]->[1], $start, $end); +} + +sub show_source($$) { + my ($self, $out) = @_; + + if (PkgLint::Logging::get_show_source_flag()) { + foreach my $line (@{$self->physlines}) { + print $out ("> " . $line->[1]); + } + } +} + +sub log_fatal($$) { + my ($self, $text) = @_; + + $self->show_source(*STDERR); + PkgLint::Logging::log_fatal($self->fname, $self->[LINES], $text); +} +sub log_error($$) { + my ($self, $text) = @_; + + $self->show_source(*STDOUT); + PkgLint::Logging::log_error($self->fname, $self->[LINES], $text); +} +sub log_warning($$) { + my ($self, $text) = @_; + + $self->show_source(*STDOUT); + PkgLint::Logging::log_warning($self->fname, $self->[LINES], $text); +} +sub log_note($$) { + my ($self, $text) = @_; + + $self->show_source(*STDOUT); + PkgLint::Logging::log_note($self->fname, $self->[LINES], $text); +} +sub log_debug($$) { + my ($self, $text) = @_; + + $self->show_source(*STDOUT); + PkgLint::Logging::log_debug($self->fname, $self->[LINES], $text); +} +sub explain_error($@) { + my ($self, @texts) = @_; + + PkgLint::Logging::explain_error($self->fname, $self->[LINES], @texts); +} +sub explain_warning($@) { + my ($self, @texts) = @_; + + PkgLint::Logging::explain_warning($self->fname, $self->[LINES], @texts); +} +sub explain_note($@) { + my ($self, @texts) = @_; + + PkgLint::Logging::explain_note($self->fname, $self->[LINES], @texts); +} +sub explain_info($@) { + my ($self, @texts) = @_; + + PkgLint::Logging::explain_info($self->fname, $self->[LINES], @texts); +} + +sub to_string($) { + my ($self) = @_; + + return $self->fname . ":" . $self->[LINES] . ": " . $self->[TEXT]; +} + +sub prepend_before($$) { + my ($self, $text) = @_; + + unshift(@{$self->[BEFORE]}, [0, "$text\n"]); + $self->[CHANGED] = true; +} +sub append_before($$) { + my ($self, $text) = @_; + + push(@{$self->[BEFORE]}, [0, "$text\n"]); + $self->[CHANGED] = true; +} +sub prepend_after($$) { + my ($self, $text) = @_; + + unshift(@{$self->[AFTER]}, [0, "$text\n"]); + $self->[CHANGED] = true; +} +sub append_after($$) { + my ($self, $text) = @_; + + push(@{$self->[AFTER]}, [0, "$text\n"]); + $self->[CHANGED] = true; +} +sub delete($) { + my ($self) = @_; + + $self->[PHYSLINES] = []; + $self->[CHANGED] = true; +} +sub replace($$$) { + my ($self, $from, $to) = @_; + my $phys = $self->[PHYSLINES]; + + foreach my $i (0..$#{$phys}) { + if ($phys->[$i]->[0] != 0 && $phys->[$i]->[1] =~ s/\Q$from\E/$to/g) { + $self->[CHANGED] = true; + } + } +} +sub replace_regex($$$) { + my ($self, $from_re, $to) = @_; + my $phys = $self->[PHYSLINES]; + + foreach my $i (0..$#{$phys}) { + if ($phys->[$i]->[0] != 0 && $phys->[$i]->[1] =~ s/$from_re/$to/) { + $self->[CHANGED] = true; + } + } +} +sub set_text($$) { + my ($self, $text) = @_; + $self->[PHYSLINES] = [[0, "$text\n"]]; + $self->[CHANGED] = true; +} + +#== End of PkgLint::Line ================================================== + +1; diff --git a/pkgtools/pkglint/files/PkgLint/Logging.pm b/pkgtools/pkglint/files/PkgLint/Logging.pm new file mode 100644 index 00000000000..4e84c61d114 --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/Logging.pm @@ -0,0 +1,136 @@ +package PkgLint::Logging; +#========================================================================== +# This package provides subroutines for printing messages to the user in a +# common format. The subroutines all have the parameters C<$fname>, +# C<$lineno> and C<$message>. In case there's no appropriate filename for +# the message, NO_FILE may be passed, likewise for C<$lineno> and +# NO_LINES. Before printing, the filename is normalized, that is, +# "/foo/bar/../../" components are removed, as well as "." components. +# At the end of the program, the subroutine print_summary_and_exit should +# be called. +# +# Examples: +# log_error(NO_FILE, NO_LINES, "Invalid command line."); +# log_warning($fname, NO_LINES, "Not found."); +# log_debug($fname, $lineno, sprintf("invalid character (0x%02x).", $c)); +#========================================================================== + +use strict; +use warnings; +BEGIN { + use Exporter; + use vars qw(@ISA @EXPORT_OK); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + NO_FILE NO_LINE_NUMBER NO_LINES + log_fatal log_error log_warning log_note log_debug + explain_error explain_warning explain_info + print_summary_and_exit + set_explain set_gcc_output_format + get_show_source_flag set_show_source_flag + ); + import PkgLint::Util qw( + false true + normalize_pathname + ); +} + +use constant NO_FILE => undef; +use constant NO_LINE_NUMBER => undef; +use constant NO_LINES => undef; + +use enum qw(:LL_ FATAL ERROR WARNING NOTE DEBUG); + +use constant traditional_type => ["FATAL", "ERROR", "WARN", "NOTE", "DEBUG"]; +use constant gcc_type => ["fatal", "error", "warning", "note", "debug"]; + +my $errors = 0; +my $warnings = 0; +my $gcc_output_format = false; +my $explain_flag = false; +my $show_source_flag = false; + +sub strxvis($) { + my ($s) = @_; + + $s =~ s/([^\x09\x20-\x7e])/"\\x" . unpack("H*", $1)/eg; + return $s; +} + +sub log_message { # no prototype due to Perl weirdness + my ($level, $fname, $lineno, $message) = @_; + my ($text, $sep); + + if (defined($fname)) { + $fname = normalize_pathname($fname); + } + + $text = ""; + $sep = ""; + if (!$gcc_output_format) { + $text .= "${sep}" . traditional_type->[$level] . ":"; + $sep = " "; + } + if (defined($fname)) { + $text .= defined($lineno) + ? "${sep}${fname}:${lineno}" + : "${sep}${fname}"; + $sep = ": "; + } + if ($gcc_output_format) { + $text .= "${sep}" . gcc_type->[$level] . ":"; + $sep = " "; + } + if (defined($message)) { + $text .= $sep . strxvis($message); + $sep = ""; + } + + if ($level == LL_FATAL) { + print STDERR ("${text}\n"); + } else { + print STDOUT ("${text}\n"); + } +} + +sub log_fatal($$$) { log_message(LL_FATAL, @_); exit(1); } +sub log_error($$$) { log_message(LL_ERROR, @_); $errors++; } +sub log_warning($$$) { log_message(LL_WARNING, @_); $warnings++; } +sub log_note($$$) { log_message(LL_NOTE, @_); } +sub log_debug($$$) { log_message(LL_DEBUG, @_); } + +sub explain { # no prototype due to Perl weirdness + my ($loglevel, $fname, $lines, @texts) = @_; + my $out = ($loglevel == LL_FATAL) ? *STDERR : *STDOUT; + + if ($explain_flag) { + foreach my $text ("", @texts, "") { + print $out ("\t${text}\n"); + } + } +} +sub explain_error($$@) { explain(LL_ERROR, @_); } +sub explain_warning($$@) { explain(LL_WARNING, @_); } +sub explain_note($$@) { explain(LL_NOTE, @_); } + +sub print_summary_and_exit($) { + my ($quiet) = @_; + + if (!$quiet) { + if ($errors != 0 || $warnings != 0) { + print("$errors errors and $warnings warnings found." . ($explain_flag ? "" : " (Use -e for more details.)") . "\n"); + } else { + print "looks fine.\n"; + } + } + exit($errors != 0); +} + +sub set_explain() { $explain_flag = true; } +sub set_gcc_output_format() { $gcc_output_format = true; } +sub get_show_source_flag() { return $show_source_flag; } +sub set_show_source_flag() { $show_source_flag = true; } + +#== End of PkgLint::Logging =============================================== + +1; diff --git a/pkgtools/pkglint/files/PkgLint/SimpleMatch.pm b/pkgtools/pkglint/files/PkgLint/SimpleMatch.pm new file mode 100644 index 00000000000..e3db828432e --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/SimpleMatch.pm @@ -0,0 +1,42 @@ +#========================================================================== +# A SimpleMatch is the result of applying a regular expression to a Perl +# scalar value. It can return the range and the text of the captured +# groups. +#========================================================================== +package PkgLint::SimpleMatch; + +use enum qw(STRING STARTS ENDS N); + +sub new($$) { + my ($class, $string, $starts, $ends) = @_; + my ($self) = ([$string, [@{$starts}], [@{$ends}], $#{$ends}]); + bless($self, $class); + return $self; +} + +sub string($) { return shift()->[STRING]; } +sub n($) { return shift()->[N]; } + +sub has($$) { + my ($self, $n) = @_; + + return 0 <= $n && $n <= $self->n + && defined($self->[STARTS]->[$n]) + && defined($self->[ENDS]->[$n]); +} + +sub text($$) { + my ($self, $n) = @_; + + my $start = $self->[STARTS]->[$n]; + my $end = $self->[ENDS]->[$n]; + return substr($self->string, $start, $end - $start); +} + +sub range($$) { + my ($self, $n) = @_; + + return ($self->[STARTS]->[$n], $self->[ENDS]->[$n]); +} + +1; diff --git a/pkgtools/pkglint/files/PkgLint/SubstContext.pm b/pkgtools/pkglint/files/PkgLint/SubstContext.pm new file mode 100644 index 00000000000..fc9fbd637ef --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/SubstContext.pm @@ -0,0 +1,197 @@ +package PkgLint::SubstContext; +#========================================================================== +# This class records the state of a block of variable assignments that make +# up a SUBST class. As these variable assignments are not easy to get right +# unless you do it every day, and the possibility of typos is high, pkglint +# provides additional checks for them. +#========================================================================== + +BEGIN { + import PkgLint::Util qw( + false true + ); + import PkgLint::Logging qw( + log_warning + ); +} + +use enum qw(:SUBST_ ID CLASS STAGE MESSAGE FILES SED VARS FILTER_CMD); + +sub new($) { + my ($class) = @_; + my ($self) = ([undef, undef, undef, undef, [], [], [], undef]); + bless($self, $class); + return $self; +} + +sub subst_class($) { return shift()->[SUBST_CLASS]; } +sub subst_stage($) { return shift()->[SUBST_STAGE]; } +sub subst_message($) { return shift()->[SUBST_MESSAGE]; } +sub subst_files($) { return shift()->[SUBST_FILES]; } +sub subst_sed($) { return shift()->[SUBST_SED]; } +sub subst_vars($) { return shift()->[SUBST_VARS]; } +sub subst_filter_cmd($) { return shift()->[SUBST_FILTER_CMD]; } +sub subst_id($) { return shift()->[SUBST_ID]; } + +sub init($) { + my ($self) = @_; + + $self->[SUBST_ID] = undef; + $self->[SUBST_CLASS] = undef; + $self->[SUBST_STAGE] = undef; + $self->[SUBST_MESSAGE] = undef; + $self->[SUBST_FILES] = []; + $self->[SUBST_SED] = []; + $self->[SUBST_VARS] = []; + $self->[SUBST_FILTER_CMD] = undef; +} + +sub check_end($$) { + my ($self, $line) = @_; + + return unless defined($self->subst_id); + + if (!defined($self->subst_class)) { + $main::opt_warn_extra and $line->log_warning("Incomplete SUBST block: SUBST_CLASSES missing."); + } + if (!defined($self->subst_stage)) { + $main::opt_warn_extra and $line->log_warning("Incomplete SUBST block: SUBST_STAGE missing."); + } + if (@{$self->subst_files} == 0) { + $main::opt_warn_extra and $line->log_warning("Incomplete SUBST block: SUBST_FILES missing."); + } + if (@{$self->subst_sed} == 0 && @{$self->subst_vars} == 0 && !defined($self->subst_filter_cmd)) { + $main::opt_warn_extra and $line->log_warning("Incomplete SUBST block: SUBST_SED or SUBST_VARS missing."); + } + $self->init(); +} + +sub is_complete($) { + my ($self) = @_; + + return false unless defined($self->subst_id); + return false unless defined($self->subst_class); + return false unless defined($self->subst_files); + return false if @{$self->subst_sed} == 0 && @{$self->subst_vars} == 0; + return true; +} + +sub check_varassign($$$$$) { + my ($self, $line, $varname, $op, $value) = @_; + my ($varbase, $varparam, $id); + + if ($varname eq "SUBST_CLASSES") { + + if ($value =~ m"^(\S+)\s") { + $main::opt_warn_extra and $line->log_warning("Please add only one class at a time to SUBST_CLASSES."); + $self->[SUBST_CLASS] = $1; + $self->[SUBST_ID] = $1; + + } else { + if (defined($self->subst_class)) { + $main::opt_warn_extra and $line->log_warning("SUBST_CLASSES should only appear once in a SUBST block."); + } + $self->[SUBST_CLASS] = $value; + $self->[SUBST_ID] = $value; + } + return; + } + + $id = $self->subst_id; + + if ($varname =~ m"^(SUBST_(?:STAGE|MESSAGE|FILES|SED|VARS|FILTER_CMD))\.([\-\w_]+)$") { + ($varbase, $varparam) = ($1, $2); + + if (!defined($id)) { + $main::opt_warn_extra and $line->log_note("SUBST_CLASSES should precede the definition of ${varbase}.${varparam}."); + + $id = $self->[SUBST_ID] = $varparam; + } + } else { + if (defined($id)) { + $main::opt_warn_extra and $line->log_warning("Foreign variable in SUBST block."); + } + return; + } + + if ($varparam ne $id) { + + # XXX: This code sometimes produces weird warnings. See + # meta-pkgs/xorg/Makefile.common 1.41 for an example. + if ($self->is_complete()) { + $self->check_end($line); + + # The following assignment prevents an additional warning, + # but from a technically viewpoint, it is incorrect. + $self->[SUBST_CLASS] = $varparam; + $self->[SUBST_ID] = $varparam; + $id = $varparam; + } else { + $main::opt_warn_extra and $line->log_warning("Variable parameter \"${varparam}\" does not match SUBST class \"${id}\"."); + } + } + + if ($varbase eq "SUBST_STAGE") { + if (defined($self->subst_stage)) { + $main::opt_warn_extra and $line->log_warning("Duplicate definition of SUBST_STAGE.${id}."); + } else { + $self->[SUBST_STAGE] = $value; + } + + } elsif ($varbase eq "SUBST_MESSAGE") { + if (defined($self->subst_message)) { + $main::opt_warn_extra and $line->log_warning("Duplicate definition of SUBST_MESSAGE.${id}."); + } else { + $self->[SUBST_MESSAGE] = $value; + } + + } elsif ($varbase eq "SUBST_FILES") { + if (@{$self->subst_files} > 0) { + if ($op ne "+=") { + $main::opt_warn_extra and $line->log_warning("All but the first SUBST_FILES line should use the \"+=\" operator."); + } + } + push(@{$self->subst_files}, $value); + + } elsif ($varbase eq "SUBST_SED") { + if (@{$self->subst_sed} > 0) { + if ($op ne "+=") { + $main::opt_warn_extra and $line->log_warning("All but the first SUBST_SED line should use the \"+=\" operator."); + } + } + push(@{$self->subst_sed}, $value); + + } elsif ($varbase eq "SUBST_FILTER_CMD") { + if (defined($self->subst_filter_cmd)) { + $main::opt_warn_extra and $line->log_warning("Duplicate definition of SUBST_FILTER_CMD.${id}."); + } else { + $self->[SUBST_FILTER_CMD] = $value; + } + + } elsif ($varbase eq "SUBST_VARS") { + if (@{$self->subst_vars} > 0) { + if ($op ne "+=") { + $main::opt_warn_extra and $line->log_warning("All but the first SUBST_VARS line should use the \"+=\" operator."); + } + } + push(@{$self->subst_vars}, $value); + + } else { + $main::opt_warn_extra and $line->log_warning("Foreign variable in SUBST block."); + } +} + +sub to_string($) { + my ($self) = @_; + + return sprintf("SubstContext(%s %s %s %s %s %s)", + (defined($self->subst_class) ? $self->subst_class : "(undef)"), + (defined($self->subst_stage) ? $self->subst_stage : "(undef)"), + (defined($self->subst_message) ? $self->subst_message : "(undef)"), + scalar(@{$self->subst_files}), + scalar(@{$self->subst_sed}), + (defined($self->subst_id) ? $self->subst_id : "(undef)")); +} +#== End of PkgLint::SubstContext ========================================== + +1; diff --git a/pkgtools/pkglint/files/PkgLint/Type.pm b/pkgtools/pkglint/files/PkgLint/Type.pm new file mode 100644 index 00000000000..3f542620c4e --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/Type.pm @@ -0,0 +1,102 @@ +package PkgLint::Type; +#========================================================================== +# A Type in pkglint is a combination of a data type and a permission +# specification. Further details can be found in the chapter ``The pkglint +# type system'' of the pkglint book. +#========================================================================== + +BEGIN { + import PkgLint::Util qw( + false true + ); + import PkgLint::Logging qw( + log_warning NO_LINES + ); + use Exporter; + use vars qw(@ISA @EXPORT_OK); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + LK_NONE LK_INTERNAL LK_EXTERNAL + GUESSED NOT_GUESSED + ); +} + +use enum qw(KIND_OF_LIST BASIC_TYPE ACLS IS_GUESSED); +use enum qw(:LK_ NONE INTERNAL EXTERNAL); +use enum qw(:ACLE_ SUBJECT_RE PERMS); +use enum qw(NOT_GUESSED GUESSED); + +sub new($$$) { + my ($class, $kind_of_list, $basic_type, $acls, $guessed) = @_; + my ($self) = ([$kind_of_list, $basic_type, $acls, $guessed]); + bless($self, $class); + return $self; +} + +sub kind_of_list($) { return shift()->[KIND_OF_LIST]; } +sub basic_type($) { return shift()->[BASIC_TYPE]; } +# no getter method for acls +sub is_guessed($) { return shift()->[IS_GUESSED]; } + +sub perms($$) { + my ($self, $fname) = @_; + my ($perms); + + foreach my $acl_entry (@{$self->[ACLS]}) { + if ($fname =~ $acl_entry->[ACLE_SUBJECT_RE]) { + return $acl_entry->[ACLE_PERMS]; + } + } + return undef; +} + +# Returns the union of all possible permissions. This can be used to +# check whether a variable may be defined or used at all, or if it is +# read-only. +sub perms_union($) { + my ($self) = @_; + my ($perms); + + $perms = ""; + foreach my $acl_entry(@{$self->[ACLS]}) { + $perms .= $acl_entry->[ACLE_PERMS]; + } + return $perms; +} + +# Returns whether the type is considered an external list. All external +# lists are, of course, as well as some other data types that are not +# defined as lists to make the implementation of checkline_mk_vartype +# easier. +sub is_practically_a_list($) { + my ($self) = @_; + + return ($self->kind_of_list == LK_EXTERNAL) ? true + : ($self->kind_of_list == LK_INTERNAL) ? false + : ($self->basic_type eq "BuildlinkPackages") ? true + : ($self->basic_type eq "SedCommands") ? true + : ($self->basic_type eq "ShellCommand") ? true + : false; +} + +# Returns whether variables of this type may be extended using the "+=" +# operator. +sub may_use_plus_eq($) { + my ($self) = @_; + + return ($self->kind_of_list != LK_NONE) ? true + : ($self->basic_type eq "AwkCommand") ? true + : ($self->basic_type eq "BuildlinkPackages") ? true + : ($self->basic_type eq "SedCommands") ? true + : false; +} + +sub to_string($) { + my ($self) = @_; + + return (["", "InternalList of ", "List of "]->[$self->kind_of_list]) . $self->basic_type; +} + +#== End of PkgLint::Type ================================================== + +1; diff --git a/pkgtools/pkglint/files/PkgLint/Util.pm b/pkgtools/pkglint/files/PkgLint/Util.pm new file mode 100644 index 00000000000..2edecf8b330 --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/Util.pm @@ -0,0 +1,95 @@ +package PkgLint::Util; +#========================================================================== +# This package is a catch-all for subroutines that are not application-spe- +# cific. Currently it contains the boolean constants C<false> and C<true>, +# as well as a function to print text in a table format, and a function +# that converts an array into a hash. The latter is just for convenience +# because I don't know of a Perl operator similar to qw() that can be used +# for creating a hash. +#========================================================================== +BEGIN { + use Exporter; + use vars qw(@ISA @EXPORT_OK); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + assert + false true dont_know doesnt_matter + array_to_hash normalize_pathname print_table + ); +} + +use enum qw(false true dont_know doesnt_matter); + +sub assert($$) { + my ($cond, $msg) = @_; + my (@callers, $n); + + if (!$cond) { + print STDERR ("FATAL: Assertion failed: ${msg}.\n"); + + for ($n = 0; my @info = caller($n); $n++) { + push(@callers, [$info[2], $info[3]]); + } + + for (my $i = $#callers; $i >= 0; $i--) { + my $info = $callers[$i]; + printf STDERR (" line %4d called %s\n", $info->[0], $info->[1]); + } + exit(1); + } +} + +# Prints the C<$table> on the C<$out> stream. The C<$table> shall be an +# array of rows, each row shall be an array of cells, and each cell shall +# be a string. +sub print_table($$) { + my ($out, $table) = @_; + my (@width) = (); + foreach my $row (@{$table}) { + foreach my $i (0..$#{$row}) { + if (!defined($width[$i]) || length($row->[$i]) > $width[$i]) { + $width[$i] = length($row->[$i]); + } + } + } + foreach my $row (@{$table}) { + my ($max) = ($#{$row}); + foreach my $i (0..$max) { + if ($i != 0) { + print $out (" "); + } + print $out ($row->[$i]); + if ($i != $max) { + print $out (" " x ($width[$i] - length($row->[$i]))); + } + } + print $out ("\n"); + } +} + +sub array_to_hash(@) { + my ($result) = {}; + + foreach my $arg (@_) { + $result->{$arg} = 1; + } + return $result; +} + +sub normalize_pathname($) { + my ($fname) = @_; + + # strip "." path components + $fname =~ s,^(?:\./)+,,; + $fname =~ s,/(?:\./)+,/,g; + $fname =~ s,/+,/,g; + + # strip intermediate "../.." path components + while ($fname =~ s,/[^.][^/]*/[^.][^/]*/\.\./\.\./,/,) { + } + + return $fname; +} +#== End of PkgLint::Util ================================================== + +1; diff --git a/pkgtools/pkglint/files/PkgLint/VarUseContext.pm b/pkgtools/pkglint/files/PkgLint/VarUseContext.pm new file mode 100644 index 00000000000..308f809f410 --- /dev/null +++ b/pkgtools/pkglint/files/PkgLint/VarUseContext.pm @@ -0,0 +1,69 @@ +package PkgLint::VarUseContext; +#========================================================================== +# This class represents the various contexts in which make(1) variables can +# appear in pkgsrc. Further details can be found in the chapter ``The +# pkglint type system'' of the pkglint book. +#========================================================================== + +BEGIN { + import PkgLint::Util qw( + false true + ); + import PkgLint::Logging qw( + log_warning NO_LINES + ); + use Exporter; + use vars qw(@ISA @EXPORT_OK); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + VUC_TIME_UNKNOWN VUC_TIME_LOAD VUC_TIME_RUN + VUC_TYPE_UNKNOWN + VUC_SHELLWORD_UNKNOWN VUC_SHELLWORD_PLAIN VUC_SHELLWORD_DQUOT + VUC_SHELLWORD_SQUOT VUC_SHELLWORD_BACKT VUC_SHELLWORD_FOR + VUC_EXTENT_UNKNOWN VUC_EXTENT_FULL VUC_EXTENT_WORD + VUC_EXTENT_WORD_PART + ); +} + +use enum qw(TIME TYPE SHELLWORD EXTENT); +use enum qw(:VUC_TIME_ UNKNOWN LOAD RUN); +use constant VUC_TYPE_UNKNOWN => undef; +use enum qw(:VUC_SHELLWORD_ UNKNOWN PLAIN DQUOT SQUOT BACKT FOR); +use enum qw(:VUC_EXTENT_ UNKNOWN FULL WORD WORD_PART); + +my $pool = {}; + +sub new($$$$$) { + my ($class, $time, $type, $shellword, $extent) = @_; + my ($self) = ([$time, $type, $shellword, $extent]); + bless($self, $class); + return $self; +} +sub new_from_pool($$$$$) { + my ($class, $time, $type, $shellword, $extent) = @_; + my $key = "${time}-${type}-${shellword}-${extent}"; + + if (!exists($pool->{$key})) { + $pool->{$key} = $class->new($time, $type, $shellword, $extent); + } + return $pool->{$key}; +} + +sub time($) { return shift()->[TIME]; } +sub type($) { return shift()->[TYPE]; } +sub shellword($) { return shift()->[SHELLWORD]; } +sub extent($) { return shift()->[EXTENT]; } + +sub to_string($) { + my ($self) = @_; + + return sprintf("(%s %s %s %s)", + ["unknown-time", "load-time", "run-time"]->[$self->time], + (defined($self->type) ? $self->type->to_string() : "no-type"), + ["none", "plain", "squot", "dquot", "backt", "for"]->[$self->shellword], + ["unknown", "full", "word", "word-part"]->[$self->extent]); +} + +#== End of PkgLint::VarUseContext ========================================= + +1; diff --git a/pkgtools/pkglint/files/build.pl b/pkgtools/pkglint/files/build.pl new file mode 100644 index 00000000000..97caff3b4c0 --- /dev/null +++ b/pkgtools/pkglint/files/build.pl @@ -0,0 +1,25 @@ +#! @PERL@ +# $NetBSD: build.pl,v 1.1 2013/03/26 15:08:29 schmonz Exp $ +# + +use strict; +use warnings; + +sub readfile { + my $file = shift; + + local $/ = undef; + open(my $in, "<", $file) || die "failed to read $file: $!"; + my $contents = <$in>; + close($in) || die "failed to read $file: $!"; + + return $contents; +} + +while (my $line = <>) { + if ($line =~ /^use PkgLint::(.+);$/) { + print readfile("PkgLint/$1.pm"); + } else { + print $line; + } +} diff --git a/pkgtools/pkglint/files/pkglint.pl b/pkgtools/pkglint/files/pkglint.pl index 64095b195a2..ec860241749 100644 --- a/pkgtools/pkglint/files/pkglint.pl +++ b/pkgtools/pkglint/files/pkglint.pl @@ -1,5 +1,5 @@ #! @PERL@ -# $NetBSD: pkglint.pl,v 1.850 2013/03/06 12:30:01 obache Exp $ +# $NetBSD: pkglint.pl,v 1.851 2013/03/26 15:08:29 schmonz Exp $ # # pkglint - static analyzer and checker for pkgsrc packages @@ -34,1057 +34,16 @@ use strict; use warnings; -package PkgLint::Util; -#========================================================================== -# This package is a catch-all for subroutines that are not application-spe- -# cific. Currently it contains the boolean constants C<false> and C<true>, -# as well as a function to print text in a table format, and a function -# that converts an array into a hash. The latter is just for convenience -# because I don't know of a Perl operator similar to qw() that can be used -# for creating a hash. -#========================================================================== -BEGIN { - use Exporter; - use vars qw(@ISA @EXPORT_OK); - @ISA = qw(Exporter); - @EXPORT_OK = qw( - assert - false true dont_know doesnt_matter - array_to_hash normalize_pathname print_table - ); -} - -use enum qw(false true dont_know doesnt_matter); - -sub assert($$) { - my ($cond, $msg) = @_; - my (@callers, $n); - - if (!$cond) { - print STDERR ("FATAL: Assertion failed: ${msg}.\n"); - - for ($n = 0; my @info = caller($n); $n++) { - push(@callers, [$info[2], $info[3]]); - } - - for (my $i = $#callers; $i >= 0; $i--) { - my $info = $callers[$i]; - printf STDERR (" line %4d called %s\n", $info->[0], $info->[1]); - } - exit(1); - } -} - -# Prints the C<$table> on the C<$out> stream. The C<$table> shall be an -# array of rows, each row shall be an array of cells, and each cell shall -# be a string. -sub print_table($$) { - my ($out, $table) = @_; - my (@width) = (); - foreach my $row (@{$table}) { - foreach my $i (0..$#{$row}) { - if (!defined($width[$i]) || length($row->[$i]) > $width[$i]) { - $width[$i] = length($row->[$i]); - } - } - } - foreach my $row (@{$table}) { - my ($max) = ($#{$row}); - foreach my $i (0..$max) { - if ($i != 0) { - print $out (" "); - } - print $out ($row->[$i]); - if ($i != $max) { - print $out (" " x ($width[$i] - length($row->[$i]))); - } - } - print $out ("\n"); - } -} - -sub array_to_hash(@) { - my ($result) = {}; - - foreach my $arg (@_) { - $result->{$arg} = 1; - } - return $result; -} - -sub normalize_pathname($) { - my ($fname) = @_; - - # strip "." path components - $fname =~ s,^(?:\./)+,,; - $fname =~ s,/(?:\./)+,/,g; - $fname =~ s,/+,/,g; - - # strip intermediate "../.." path components - while ($fname =~ s,/[^.][^/]*/[^.][^/]*/\.\./\.\./,/,) { - } - - return $fname; -} -#== End of PkgLint::Util ================================================== - -package PkgLint::Logging; -#========================================================================== -# This package provides subroutines for printing messages to the user in a -# common format. The subroutines all have the parameters C<$fname>, -# C<$lineno> and C<$message>. In case there's no appropriate filename for -# the message, NO_FILE may be passed, likewise for C<$lineno> and -# NO_LINES. Before printing, the filename is normalized, that is, -# "/foo/bar/../../" components are removed, as well as "." components. -# At the end of the program, the subroutine print_summary_and_exit should -# be called. -# -# Examples: -# log_error(NO_FILE, NO_LINES, "Invalid command line."); -# log_warning($fname, NO_LINES, "Not found."); -# log_debug($fname, $lineno, sprintf("invalid character (0x%02x).", $c)); -#========================================================================== - -use strict; -use warnings; -BEGIN { - use Exporter; - use vars qw(@ISA @EXPORT_OK); - @ISA = qw(Exporter); - @EXPORT_OK = qw( - NO_FILE NO_LINE_NUMBER NO_LINES - log_fatal log_error log_warning log_note log_debug - explain_error explain_warning explain_info - print_summary_and_exit - set_explain set_gcc_output_format - get_show_source_flag set_show_source_flag - ); - import PkgLint::Util qw( - false true - normalize_pathname - ); -} - -use constant NO_FILE => undef; -use constant NO_LINE_NUMBER => undef; -use constant NO_LINES => undef; - -use enum qw(:LL_ FATAL ERROR WARNING NOTE DEBUG); - -use constant traditional_type => ["FATAL", "ERROR", "WARN", "NOTE", "DEBUG"]; -use constant gcc_type => ["fatal", "error", "warning", "note", "debug"]; - -my $errors = 0; -my $warnings = 0; -my $gcc_output_format = false; -my $explain_flag = false; -my $show_source_flag = false; - -sub strxvis($) { - my ($s) = @_; - - $s =~ s/([^\x09\x20-\x7e])/"\\x" . unpack("H*", $1)/eg; - return $s; -} - -sub log_message { # no prototype due to Perl weirdness - my ($level, $fname, $lineno, $message) = @_; - my ($text, $sep); - - if (defined($fname)) { - $fname = normalize_pathname($fname); - } - - $text = ""; - $sep = ""; - if (!$gcc_output_format) { - $text .= "${sep}" . traditional_type->[$level] . ":"; - $sep = " "; - } - if (defined($fname)) { - $text .= defined($lineno) - ? "${sep}${fname}:${lineno}" - : "${sep}${fname}"; - $sep = ": "; - } - if ($gcc_output_format) { - $text .= "${sep}" . gcc_type->[$level] . ":"; - $sep = " "; - } - if (defined($message)) { - $text .= $sep . strxvis($message); - $sep = ""; - } - - if ($level == LL_FATAL) { - print STDERR ("${text}\n"); - } else { - print STDOUT ("${text}\n"); - } -} - -sub log_fatal($$$) { log_message(LL_FATAL, @_); exit(1); } -sub log_error($$$) { log_message(LL_ERROR, @_); $errors++; } -sub log_warning($$$) { log_message(LL_WARNING, @_); $warnings++; } -sub log_note($$$) { log_message(LL_NOTE, @_); } -sub log_debug($$$) { log_message(LL_DEBUG, @_); } - -sub explain { # no prototype due to Perl weirdness - my ($loglevel, $fname, $lines, @texts) = @_; - my $out = ($loglevel == LL_FATAL) ? *STDERR : *STDOUT; - - if ($explain_flag) { - foreach my $text ("", @texts, "") { - print $out ("\t${text}\n"); - } - } -} -sub explain_error($$@) { explain(LL_ERROR, @_); } -sub explain_warning($$@) { explain(LL_WARNING, @_); } -sub explain_note($$@) { explain(LL_NOTE, @_); } - -sub print_summary_and_exit($) { - my ($quiet) = @_; - - if (!$quiet) { - if ($errors != 0 || $warnings != 0) { - print("$errors errors and $warnings warnings found." . ($explain_flag ? "" : " (Use -e for more details.)") . "\n"); - } else { - print "looks fine.\n"; - } - } - exit($errors != 0); -} - -sub set_explain() { $explain_flag = true; } -sub set_gcc_output_format() { $gcc_output_format = true; } -sub get_show_source_flag() { return $show_source_flag; } -sub set_show_source_flag() { $show_source_flag = true; } - -#== End of PkgLint::Logging =============================================== - -#========================================================================== -# A SimpleMatch is the result of applying a regular expression to a Perl -# scalar value. It can return the range and the text of the captured -# groups. -#========================================================================== -package PkgLint::SimpleMatch; - -use enum qw(STRING STARTS ENDS N); - -sub new($$) { - my ($class, $string, $starts, $ends) = @_; - my ($self) = ([$string, [@{$starts}], [@{$ends}], $#{$ends}]); - bless($self, $class); - return $self; -} - -sub string($) { return shift()->[STRING]; } -sub n($) { return shift()->[N]; } - -sub has($$) { - my ($self, $n) = @_; - - return 0 <= $n && $n <= $self->n - && defined($self->[STARTS]->[$n]) - && defined($self->[ENDS]->[$n]); -} - -sub text($$) { - my ($self, $n) = @_; - - my $start = $self->[STARTS]->[$n]; - my $end = $self->[ENDS]->[$n]; - return substr($self->string, $start, $end - $start); -} - -sub range($$) { - my ($self, $n) = @_; - - return ($self->[STARTS]->[$n], $self->[ENDS]->[$n]); -} - -#========================================================================== -# When files are read in by pkglint, they are interpreted in terms of -# lines. For Makefiles, line continuations are handled properly, allowing -# multiple physical lines to end in a single logical line. For other files -# there is a 1:1 translation. -# -# A difference between the physical and the logical lines is that the -# physical lines include the line end sequence, whereas the logical lines -# do not. -# -# A logical line is a class having the read-only fields C<file>, -# C<lines>, C<text>, C<physlines> and C<is_changed>, as well as some -# methods for printing diagnostics easily. -# -# Some other methods allow modification of the physical lines, but leave -# the logical line (the C<text>) untouched. These methods are used in the -# --autofix mode. -# -# A line can have some "extra" fields that allow the results of parsing to -# be saved under a name. -#========================================================================== -package PkgLint::Line; - -BEGIN { - import PkgLint::Util qw( - false true - assert - ); -} - -use enum qw(FNAME LINES TEXT PHYSLINES CHANGED BEFORE AFTER EXTRA); - -sub new($$$$) { - my ($class, $fname, $lines, $text, $physlines) = @_; - my ($self) = ([$fname, $lines, $text, $physlines, false, [], [], {}]); - bless($self, $class); - return $self; -} - -sub fname($) { return shift()->[FNAME]; } -sub lines($) { return shift()->[LINES]; } -sub text($) { return shift()->[TEXT]; } -# Note: physlines is _not_ a simple getter method. -sub is_changed($) { return shift()->[CHANGED]; } - -# querying, getting and setting the extra values. -sub has($$) { - my ($self, $name) = @_; - return exists($self->[EXTRA]->{$name}); -} -sub get($$) { - my ($self, $name) = @_; - assert(exists($self->[EXTRA]->{$name}), "Field ${name} does not exist."); - return $self->[EXTRA]->{$name}; -} -sub set($$$) { - my ($self, $name, $value) = @_; - assert(!exists($self->[EXTRA]->{$name}), "Field ${name} already exists."); - - # Make sure that the line does not become a cyclic data structure. - my $type = ref($value); - if ($type eq "") { - # ok - } elsif ($type eq "ARRAY") { - foreach my $element (@{$value}) { - my $element_type = ref($element); - assert($element_type eq "" || $element_type eq "PkgLint::SimpleMatch", - "Invalid array data type: name=${name}, type=${element_type}."); - } - } else { - assert(false, "Invalid data: name=${name}, value=${value}."); - } - - $self->[EXTRA]->{$name} = $value; -} - -sub physlines($) { - my ($self) = @_; - return [@{$self->[BEFORE]}, @{$self->[PHYSLINES]}, @{$self->[AFTER]}]; -} - -# Only for PkgLint::String support -sub substring($$$$) { - my ($self, $line, $start, $end) = @_; - - return substr($self->[PHYSLINES]->[$line]->[1], $start, $end); -} - -sub show_source($$) { - my ($self, $out) = @_; - - if (PkgLint::Logging::get_show_source_flag()) { - foreach my $line (@{$self->physlines}) { - print $out ("> " . $line->[1]); - } - } -} - -sub log_fatal($$) { - my ($self, $text) = @_; - - $self->show_source(*STDERR); - PkgLint::Logging::log_fatal($self->fname, $self->[LINES], $text); -} -sub log_error($$) { - my ($self, $text) = @_; - - $self->show_source(*STDOUT); - PkgLint::Logging::log_error($self->fname, $self->[LINES], $text); -} -sub log_warning($$) { - my ($self, $text) = @_; - - $self->show_source(*STDOUT); - PkgLint::Logging::log_warning($self->fname, $self->[LINES], $text); -} -sub log_note($$) { - my ($self, $text) = @_; - - $self->show_source(*STDOUT); - PkgLint::Logging::log_note($self->fname, $self->[LINES], $text); -} -sub log_debug($$) { - my ($self, $text) = @_; - - $self->show_source(*STDOUT); - PkgLint::Logging::log_debug($self->fname, $self->[LINES], $text); -} -sub explain_error($@) { - my ($self, @texts) = @_; - - PkgLint::Logging::explain_error($self->fname, $self->[LINES], @texts); -} -sub explain_warning($@) { - my ($self, @texts) = @_; - - PkgLint::Logging::explain_warning($self->fname, $self->[LINES], @texts); -} -sub explain_note($@) { - my ($self, @texts) = @_; - - PkgLint::Logging::explain_note($self->fname, $self->[LINES], @texts); -} -sub explain_info($@) { - my ($self, @texts) = @_; - - PkgLint::Logging::explain_info($self->fname, $self->[LINES], @texts); -} - -sub to_string($) { - my ($self) = @_; - - return $self->fname . ":" . $self->[LINES] . ": " . $self->[TEXT]; -} - -sub prepend_before($$) { - my ($self, $text) = @_; - - unshift(@{$self->[BEFORE]}, [0, "$text\n"]); - $self->[CHANGED] = true; -} -sub append_before($$) { - my ($self, $text) = @_; - - push(@{$self->[BEFORE]}, [0, "$text\n"]); - $self->[CHANGED] = true; -} -sub prepend_after($$) { - my ($self, $text) = @_; - - unshift(@{$self->[AFTER]}, [0, "$text\n"]); - $self->[CHANGED] = true; -} -sub append_after($$) { - my ($self, $text) = @_; - - push(@{$self->[AFTER]}, [0, "$text\n"]); - $self->[CHANGED] = true; -} -sub delete($) { - my ($self) = @_; - - $self->[PHYSLINES] = []; - $self->[CHANGED] = true; -} -sub replace($$$) { - my ($self, $from, $to) = @_; - my $phys = $self->[PHYSLINES]; - - foreach my $i (0..$#{$phys}) { - if ($phys->[$i]->[0] != 0 && $phys->[$i]->[1] =~ s/\Q$from\E/$to/g) { - $self->[CHANGED] = true; - } - } -} -sub replace_regex($$$) { - my ($self, $from_re, $to) = @_; - my $phys = $self->[PHYSLINES]; - - foreach my $i (0..$#{$phys}) { - if ($phys->[$i]->[0] != 0 && $phys->[$i]->[1] =~ s/$from_re/$to/) { - $self->[CHANGED] = true; - } - } -} -sub set_text($$) { - my ($self, $text) = @_; - $self->[PHYSLINES] = [[0, "$text\n"]]; - $self->[CHANGED] = true; -} - -#== End of PkgLint::Line ================================================== - -package PkgLint::FileUtil; -#========================================================================== -# This package provides subroutines for loading and saving line-oriented -# files. The load_file() subroutine loads a file completely into memory, -# optionally handling continuation line folding. The load_lines() subrou- -# tine is an abbreviation for the common case of loading files without -# continuation lines. The save_autofix_changes() subroutine examines an -# array of lines if some of them have changed. It then saves the modified -# files. -#========================================================================== -use strict; -use warnings; - -BEGIN { - use Exporter; - use vars qw(@ISA @EXPORT_OK); - @ISA = qw(Exporter); - @EXPORT_OK = qw( - load_file load_lines - save_autofix_changes - ); - - import PkgLint::Util qw( - false true - ); - import PkgLint::Logging qw( - NO_LINE_NUMBER - log_error log_note - ); -} - -sub load_physical_lines($) { - my ($fname) = @_; - my ($physlines, $line, $lineno); - - $physlines = []; - open(F, "< $fname") or return undef; - $lineno = 0; - while (defined($line = <F>)) { - $lineno++; - push(@{$physlines}, [$lineno, $line]); - } - close(F) or return undef; - return $physlines; -} - -sub get_logical_line($$$) { - my ($fname, $lines, $ref_lineno) = @_; - my ($value, $lineno, $first, $firstlineno, $lastlineno, $physlines); - - $value = ""; - $first = true; - $lineno = ${$ref_lineno}; - $firstlineno = $lines->[$lineno]->[0]; - $physlines = []; - - for (; $lineno <= $#{$lines}; $lineno++) { - if ($lines->[$lineno]->[1] =~ m"^([ \t]*)(.*?)([ \t]*)(\\?)\n?$") { - my ($indent, $text, $outdent, $cont) = ($1, $2, $3, $4); - - if ($first) { - $value .= $indent; - $first = false; - } - - $value .= $text; - push(@{$physlines}, $lines->[$lineno]); - - if ($cont eq "\\") { - $value .= " "; - } else { - $value .= $outdent; - last; - } - } - } - - if ($lineno > $#{$lines}) { - # The last line in the file is a continuation line - $lineno--; - } - $lastlineno = $lines->[$lineno]->[0]; - ${$ref_lineno} = $lineno + 1; - - return PkgLint::Line->new($fname, - $firstlineno == $lastlineno - ? $firstlineno - : "$firstlineno--$lastlineno", - $value, - $physlines); -} - -sub load_lines($$) { - my ($fname, $fold_backslash_lines) = @_; - my ($physlines, $seen_newline, $loglines); - - $physlines = load_physical_lines($fname); - if (!$physlines) { - return false; - } - - $seen_newline = true; - $loglines = []; - if ($fold_backslash_lines) { - for (my $lineno = 0; $lineno <= $#{$physlines}; ) { - push(@{$loglines}, get_logical_line($fname, $physlines, \$lineno)); - } - } else { - foreach my $physline (@{$physlines}) { - my $text = $physline->[1]; - - $text =~ s/\n$//; - push(@{$loglines}, PkgLint::Line->new($fname, $physline->[0], $text, [$physline])); - } - } - - if (0 <= $#{$physlines} && $physlines->[-1]->[1] !~ m"\n$") { - log_error($fname, $physlines->[-1]->[0], "File must end with a newline."); - } - - return $loglines; -} - -sub load_file($) { - my ($fname) = @_; - - return load_lines($fname, false); -} - -sub save_autofix_changes($) { - my ($lines) = @_; - - my (%changed, %physlines); - - foreach my $line (@{$lines}) { - if ($line->is_changed) { - $changed{$line->fname}++; - } - push(@{$physlines{$line->fname}}, @{$line->physlines}); - } - - foreach my $fname (sort(keys(%changed))) { - my $new = "${fname}.pkglint.tmp"; - - if (!open(F, ">", $new)) { - log_error($new, NO_LINE_NUMBER, "$!"); - next; - } - foreach my $physline (@{$physlines{$fname}}) { - print F ($physline->[1]); - } - if (!close(F)) { - log_error($new, NO_LINE_NUMBER, "$!"); - next; - } - - if (!rename($new, $fname)) { - log_error($fname, NO_LINE_NUMBER, "$!"); - next; - } - log_note($fname, NO_LINE_NUMBER, "Has been autofixed. Please re-run pkglint."); - } -} - -#== End of PkgLint::FileUtil ============================================== - -package PkgLint::Type; -#========================================================================== -# A Type in pkglint is a combination of a data type and a permission -# specification. Further details can be found in the chapter ``The pkglint -# type system'' of the pkglint book. -#========================================================================== - -BEGIN { - import PkgLint::Util qw( - false true - ); - import PkgLint::Logging qw( - log_warning NO_LINES - ); - use Exporter; - use vars qw(@ISA @EXPORT_OK); - @ISA = qw(Exporter); - @EXPORT_OK = qw( - LK_NONE LK_INTERNAL LK_EXTERNAL - GUESSED NOT_GUESSED - ); -} - -use enum qw(KIND_OF_LIST BASIC_TYPE ACLS IS_GUESSED); -use enum qw(:LK_ NONE INTERNAL EXTERNAL); -use enum qw(:ACLE_ SUBJECT_RE PERMS); -use enum qw(NOT_GUESSED GUESSED); - -sub new($$$) { - my ($class, $kind_of_list, $basic_type, $acls, $guessed) = @_; - my ($self) = ([$kind_of_list, $basic_type, $acls, $guessed]); - bless($self, $class); - return $self; -} - -sub kind_of_list($) { return shift()->[KIND_OF_LIST]; } -sub basic_type($) { return shift()->[BASIC_TYPE]; } -# no getter method for acls -sub is_guessed($) { return shift()->[IS_GUESSED]; } - -sub perms($$) { - my ($self, $fname) = @_; - my ($perms); - - foreach my $acl_entry (@{$self->[ACLS]}) { - if ($fname =~ $acl_entry->[ACLE_SUBJECT_RE]) { - return $acl_entry->[ACLE_PERMS]; - } - } - return undef; -} - -# Returns the union of all possible permissions. This can be used to -# check whether a variable may be defined or used at all, or if it is -# read-only. -sub perms_union($) { - my ($self) = @_; - my ($perms); - - $perms = ""; - foreach my $acl_entry(@{$self->[ACLS]}) { - $perms .= $acl_entry->[ACLE_PERMS]; - } - return $perms; -} - -# Returns whether the type is considered an external list. All external -# lists are, of course, as well as some other data types that are not -# defined as lists to make the implementation of checkline_mk_vartype -# easier. -sub is_practically_a_list($) { - my ($self) = @_; - - return ($self->kind_of_list == LK_EXTERNAL) ? true - : ($self->kind_of_list == LK_INTERNAL) ? false - : ($self->basic_type eq "BuildlinkPackages") ? true - : ($self->basic_type eq "SedCommands") ? true - : ($self->basic_type eq "ShellCommand") ? true - : false; -} - -# Returns whether variables of this type may be extended using the "+=" -# operator. -sub may_use_plus_eq($) { - my ($self) = @_; - - return ($self->kind_of_list != LK_NONE) ? true - : ($self->basic_type eq "AwkCommand") ? true - : ($self->basic_type eq "BuildlinkPackages") ? true - : ($self->basic_type eq "SedCommands") ? true - : false; -} - -sub to_string($) { - my ($self) = @_; - - return (["", "InternalList of ", "List of "]->[$self->kind_of_list]) . $self->basic_type; -} - -#== End of PkgLint::Type ================================================== - -package PkgLint::VarUseContext; -#========================================================================== -# This class represents the various contexts in which make(1) variables can -# appear in pkgsrc. Further details can be found in the chapter ``The -# pkglint type system'' of the pkglint book. -#========================================================================== - -BEGIN { - import PkgLint::Util qw( - false true - ); - import PkgLint::Logging qw( - log_warning NO_LINES - ); - use Exporter; - use vars qw(@ISA @EXPORT_OK); - @ISA = qw(Exporter); - @EXPORT_OK = qw( - VUC_TIME_UNKNOWN VUC_TIME_LOAD VUC_TIME_RUN - VUC_TYPE_UNKNOWN - VUC_SHELLWORD_UNKNOWN VUC_SHELLWORD_PLAIN VUC_SHELLWORD_DQUOT - VUC_SHELLWORD_SQUOT VUC_SHELLWORD_BACKT VUC_SHELLWORD_FOR - VUC_EXTENT_UNKNOWN VUC_EXTENT_FULL VUC_EXTENT_WORD - VUC_EXTENT_WORD_PART - ); -} - -use enum qw(TIME TYPE SHELLWORD EXTENT); -use enum qw(:VUC_TIME_ UNKNOWN LOAD RUN); -use constant VUC_TYPE_UNKNOWN => undef; -use enum qw(:VUC_SHELLWORD_ UNKNOWN PLAIN DQUOT SQUOT BACKT FOR); -use enum qw(:VUC_EXTENT_ UNKNOWN FULL WORD WORD_PART); - -my $pool = {}; - -sub new($$$$$) { - my ($class, $time, $type, $shellword, $extent) = @_; - my ($self) = ([$time, $type, $shellword, $extent]); - bless($self, $class); - return $self; -} -sub new_from_pool($$$$$) { - my ($class, $time, $type, $shellword, $extent) = @_; - my $key = "${time}-${type}-${shellword}-${extent}"; - - if (!exists($pool->{$key})) { - $pool->{$key} = $class->new($time, $type, $shellword, $extent); - } - return $pool->{$key}; -} - -sub time($) { return shift()->[TIME]; } -sub type($) { return shift()->[TYPE]; } -sub shellword($) { return shift()->[SHELLWORD]; } -sub extent($) { return shift()->[EXTENT]; } - -sub to_string($) { - my ($self) = @_; - - return sprintf("(%s %s %s %s)", - ["unknown-time", "load-time", "run-time"]->[$self->time], - (defined($self->type) ? $self->type->to_string() : "no-type"), - ["none", "plain", "squot", "dquot", "backt", "for"]->[$self->shellword], - ["unknown", "full", "word", "word-part"]->[$self->extent]); -} - -#== End of PkgLint::VarUseContext ========================================= - -package PkgLint::SubstContext; -#========================================================================== -# This class records the state of a block of variable assignments that make -# up a SUBST class. As these variable assignments are not easy to get right -# unless you do it every day, and the possibility of typos is high, pkglint -# provides additional checks for them. -#========================================================================== - -BEGIN { - import PkgLint::Util qw( - false true - ); - import PkgLint::Logging qw( - log_warning - ); -} - -use enum qw(:SUBST_ ID CLASS STAGE MESSAGE FILES SED VARS FILTER_CMD); - -sub new($) { - my ($class) = @_; - my ($self) = ([undef, undef, undef, undef, [], [], [], undef]); - bless($self, $class); - return $self; -} - -sub subst_class($) { return shift()->[SUBST_CLASS]; } -sub subst_stage($) { return shift()->[SUBST_STAGE]; } -sub subst_message($) { return shift()->[SUBST_MESSAGE]; } -sub subst_files($) { return shift()->[SUBST_FILES]; } -sub subst_sed($) { return shift()->[SUBST_SED]; } -sub subst_vars($) { return shift()->[SUBST_VARS]; } -sub subst_filter_cmd($) { return shift()->[SUBST_FILTER_CMD]; } -sub subst_id($) { return shift()->[SUBST_ID]; } - -sub init($) { - my ($self) = @_; - - $self->[SUBST_ID] = undef; - $self->[SUBST_CLASS] = undef; - $self->[SUBST_STAGE] = undef; - $self->[SUBST_MESSAGE] = undef; - $self->[SUBST_FILES] = []; - $self->[SUBST_SED] = []; - $self->[SUBST_VARS] = []; - $self->[SUBST_FILTER_CMD] = undef; -} - -sub check_end($$) { - my ($self, $line) = @_; - - return unless defined($self->subst_id); - - if (!defined($self->subst_class)) { - $main::opt_warn_extra and $line->log_warning("Incomplete SUBST block: SUBST_CLASSES missing."); - } - if (!defined($self->subst_stage)) { - $main::opt_warn_extra and $line->log_warning("Incomplete SUBST block: SUBST_STAGE missing."); - } - if (@{$self->subst_files} == 0) { - $main::opt_warn_extra and $line->log_warning("Incomplete SUBST block: SUBST_FILES missing."); - } - if (@{$self->subst_sed} == 0 && @{$self->subst_vars} == 0 && !defined($self->subst_filter_cmd)) { - $main::opt_warn_extra and $line->log_warning("Incomplete SUBST block: SUBST_SED or SUBST_VARS missing."); - } - $self->init(); -} - -sub is_complete($) { - my ($self) = @_; - - return false unless defined($self->subst_id); - return false unless defined($self->subst_class); - return false unless defined($self->subst_files); - return false if @{$self->subst_sed} == 0 && @{$self->subst_vars} == 0; - return true; -} - -sub check_varassign($$$$$) { - my ($self, $line, $varname, $op, $value) = @_; - my ($varbase, $varparam, $id); - - if ($varname eq "SUBST_CLASSES") { - - if ($value =~ m"^(\S+)\s") { - $main::opt_warn_extra and $line->log_warning("Please add only one class at a time to SUBST_CLASSES."); - $self->[SUBST_CLASS] = $1; - $self->[SUBST_ID] = $1; - - } else { - if (defined($self->subst_class)) { - $main::opt_warn_extra and $line->log_warning("SUBST_CLASSES should only appear once in a SUBST block."); - } - $self->[SUBST_CLASS] = $value; - $self->[SUBST_ID] = $value; - } - return; - } - - $id = $self->subst_id; - - if ($varname =~ m"^(SUBST_(?:STAGE|MESSAGE|FILES|SED|VARS|FILTER_CMD))\.([\-\w_]+)$") { - ($varbase, $varparam) = ($1, $2); - - if (!defined($id)) { - $main::opt_warn_extra and $line->log_note("SUBST_CLASSES should precede the definition of ${varbase}.${varparam}."); - - $id = $self->[SUBST_ID] = $varparam; - } - } else { - if (defined($id)) { - $main::opt_warn_extra and $line->log_warning("Foreign variable in SUBST block."); - } - return; - } - - if ($varparam ne $id) { - - # XXX: This code sometimes produces weird warnings. See - # meta-pkgs/xorg/Makefile.common 1.41 for an example. - if ($self->is_complete()) { - $self->check_end($line); - - # The following assignment prevents an additional warning, - # but from a technically viewpoint, it is incorrect. - $self->[SUBST_CLASS] = $varparam; - $self->[SUBST_ID] = $varparam; - $id = $varparam; - } else { - $main::opt_warn_extra and $line->log_warning("Variable parameter \"${varparam}\" does not match SUBST class \"${id}\"."); - } - } - - if ($varbase eq "SUBST_STAGE") { - if (defined($self->subst_stage)) { - $main::opt_warn_extra and $line->log_warning("Duplicate definition of SUBST_STAGE.${id}."); - } else { - $self->[SUBST_STAGE] = $value; - } - - } elsif ($varbase eq "SUBST_MESSAGE") { - if (defined($self->subst_message)) { - $main::opt_warn_extra and $line->log_warning("Duplicate definition of SUBST_MESSAGE.${id}."); - } else { - $self->[SUBST_MESSAGE] = $value; - } - - } elsif ($varbase eq "SUBST_FILES") { - if (@{$self->subst_files} > 0) { - if ($op ne "+=") { - $main::opt_warn_extra and $line->log_warning("All but the first SUBST_FILES line should use the \"+=\" operator."); - } - } - push(@{$self->subst_files}, $value); - - } elsif ($varbase eq "SUBST_SED") { - if (@{$self->subst_sed} > 0) { - if ($op ne "+=") { - $main::opt_warn_extra and $line->log_warning("All but the first SUBST_SED line should use the \"+=\" operator."); - } - } - push(@{$self->subst_sed}, $value); - - } elsif ($varbase eq "SUBST_FILTER_CMD") { - if (defined($self->subst_filter_cmd)) { - $main::opt_warn_extra and $line->log_warning("Duplicate definition of SUBST_FILTER_CMD.${id}."); - } else { - $self->[SUBST_FILTER_CMD] = $value; - } - - } elsif ($varbase eq "SUBST_VARS") { - if (@{$self->subst_vars} > 0) { - if ($op ne "+=") { - $main::opt_warn_extra and $line->log_warning("All but the first SUBST_VARS line should use the \"+=\" operator."); - } - } - push(@{$self->subst_vars}, $value); - - } else { - $main::opt_warn_extra and $line->log_warning("Foreign variable in SUBST block."); - } -} - -sub to_string($) { - my ($self) = @_; - - return sprintf("SubstContext(%s %s %s %s %s %s)", - (defined($self->subst_class) ? $self->subst_class : "(undef)"), - (defined($self->subst_stage) ? $self->subst_stage : "(undef)"), - (defined($self->subst_message) ? $self->subst_message : "(undef)"), - scalar(@{$self->subst_files}), - scalar(@{$self->subst_sed}), - (defined($self->subst_id) ? $self->subst_id : "(undef)")); -} -#== End of PkgLint::SubstContext ========================================== - -package CVS_Entry; -#========================================================================== -# A CVS_Entry represents one line from a CVS/Entries file. -#========================================================================== - -use enum qw(FNAME REVISION MTIME TAG); - -sub new($$$$$) { - my ($class, $fname, $revision, $date, $tag) = @_; - my $self = [ $fname, $revision, $date, $tag ]; - bless($self, $class); - return $self; -} -sub fname($) { return shift()->[FNAME]; } -sub revision($) { return shift()->[REVISION]; } -sub mtime($) { return shift()->[MTIME]; } -sub tag($) { return shift()->[TAG]; } -#== End of CVS_Entry ====================================================== - -package PkgLint::Change; -#========================================================================== -# A change entry from doc/CHANGES-* -#========================================================================== - -sub new($$$$$$) { - my ($class, $line, $action, $pkgpath, $version, $author, $date) = @_; - my $self = [ $line, $action, $pkgpath, $version, $author, $date ]; - bless($self, $class); - return $self; -} -sub line($) { return shift()->[0]; } -sub action($) { return shift()->[1]; } -sub pkgpath($) { return shift()->[2]; } -sub version($) { return shift()->[3]; } -sub author($) { return shift()->[4]; } -sub date($) { return shift()->[5]; } -#== End of PkgLint::Change ================================================ +use PkgLint::Util; +use PkgLint::Logging; +use PkgLint::SimpleMatch; +use PkgLint::Line; +use PkgLint::FileUtil; +use PkgLint::Type; +use PkgLint::VarUseContext; +use PkgLint::SubstContext; +use PkgLint::CVS_Entry; +use PkgLint::Change; package main; #========================================================================== |