diff options
| -rw-r--r-- | scripts/Dpkg/Changelog/Entry.pm | 17 | ||||
| -rw-r--r-- | scripts/Dpkg/Shlibs/SymbolFile.pm | 14 | ||||
| -rw-r--r-- | scripts/Dpkg/Source/Package/V2.pm | 29 | ||||
| -rw-r--r-- | scripts/Dpkg/Source/Package/V3/quilt.pm | 44 | ||||
| -rw-r--r-- | scripts/Dpkg/Source/Patch.pm | 121 | ||||
| -rw-r--r-- | scripts/Dpkg/Version.pm | 30 | ||||
| -rw-r--r-- | test/100_critic.t | 1 |
7 files changed, 137 insertions, 119 deletions
diff --git a/scripts/Dpkg/Changelog/Entry.pm b/scripts/Dpkg/Changelog/Entry.pm index e434103d5..506716d49 100644 --- a/scripts/Dpkg/Changelog/Entry.pm +++ b/scripts/Dpkg/Changelog/Entry.pm @@ -81,19 +81,20 @@ filehandle. =cut +sub _format_output_block { + my $lines = shift; + return join('', map { $_ . "\n" } @{$lines}); +} + sub output { my ($self, $fh) = @_; my $str = ''; - sub _block { - my $lines = shift; - return join('', map { $_ . "\n" } @{$lines}); - } $str .= $self->{header} . "\n" if defined($self->{header}); - $str .= _block($self->{blank_after_header}); - $str .= _block($self->{changes}); - $str .= _block($self->{blank_after_changes}); + $str .= _format_output_block($self->{blank_after_header}); + $str .= _format_output_block($self->{changes}); + $str .= _format_output_block($self->{blank_after_changes}); $str .= $self->{trailer} . "\n" if defined($self->{trailer}); - $str .= _block($self->{blank_after_trailer}); + $str .= _format_output_block($self->{blank_after_trailer}); print $fh $str if defined $fh; return $str; } diff --git a/scripts/Dpkg/Shlibs/SymbolFile.pm b/scripts/Dpkg/Shlibs/SymbolFile.pm index 7b6eb2b50..c5204b8b5 100644 --- a/scripts/Dpkg/Shlibs/SymbolFile.pm +++ b/scripts/Dpkg/Shlibs/SymbolFile.pm @@ -189,15 +189,15 @@ sub add_symbol { } } +sub _new_symbol { + my $base = shift || 'Dpkg::Shlibs::Symbol'; + return (ref $base) ? $base->clone(@_) : $base->new(@_); +} + # Parameter seen is only used for recursive calls sub parse { my ($self, $fh, $file, $seen, $obj_ref, $base_symbol) = @_; - sub new_symbol { - my $base = shift || 'Dpkg::Shlibs::Symbol'; - return (ref $base) ? $base->clone(@_) : $base->new(@_); - } - if (defined($seen)) { return if exists $seen->{$file}; # Avoid include loops } else { @@ -219,7 +219,7 @@ sub parse { } # Symbol specification my $deprecated = ($1) ? $1 : 0; - my $sym = new_symbol($base_symbol, deprecated => $deprecated); + my $sym = _new_symbol($base_symbol, deprecated => $deprecated); if ($self->create_symbol($2, base => $sym)) { $self->add_symbol($sym, $$obj_ref); } else { @@ -231,7 +231,7 @@ sub parse { my $dir = $file; my $new_base_symbol; if (defined $tagspec) { - $new_base_symbol = new_symbol($base_symbol); + $new_base_symbol = _new_symbol($base_symbol); $new_base_symbol->parse_tagspec($tagspec); } $dir =~ s{[^/]+$}{}; # Strip filename diff --git a/scripts/Dpkg/Source/Package/V2.pm b/scripts/Dpkg/Source/Package/V2.pm index de1274769..1021d9e80 100644 --- a/scripts/Dpkg/Source/Package/V2.pm +++ b/scripts/Dpkg/Source/Package/V2.pm @@ -602,22 +602,25 @@ sub register_patch { return $patch; } +sub _is_bad_patch_name { + my ($dir, $patch_name) = @_; + + return 1 if not defined($patch_name); + return 1 if not length($patch_name); + + my $patch = File::Spec->catfile($dir, "debian", "patches", $patch_name); + if (-e $patch) { + warning(_g("cannot register changes in %s, this patch already exists"), + $patch); + return 1; + } + return 0; +} + sub do_commit { my ($self, $dir) = @_; my ($patch_name, $tmpdiff) = @{$self->{'options'}{'ARGV'}}; - sub bad_patch_name { - my ($dir, $patch_name) = @_; - return 1 if not defined($patch_name); - return 1 if not length($patch_name); - my $patch = File::Spec->catfile($dir, "debian", "patches", $patch_name); - if (-e $patch) { - warning(_g("cannot register changes in %s, this patch already exists"), $patch); - return 1; - } - return 0; - } - $self->prepare_build($dir); # Try to fix up a broken relative filename for the patch @@ -645,7 +648,7 @@ sub do_commit { info(_g("there are no local changes to record")); return; } - while (bad_patch_name($dir, $patch_name)) { + while (_is_bad_patch_name($dir, $patch_name)) { # Ask the patch name interactively print STDOUT _g("Enter the desired patch name: "); chomp($patch_name = <STDIN>); diff --git a/scripts/Dpkg/Source/Package/V3/quilt.pm b/scripts/Dpkg/Source/Package/V3/quilt.pm index 3b7d0e319..f32a49909 100644 --- a/scripts/Dpkg/Source/Package/V3/quilt.pm +++ b/scripts/Dpkg/Source/Package/V3/quilt.pm @@ -214,25 +214,27 @@ sub check_patches_applied { $self->apply_patches($dir, usage => 'preparation', verbose => 1); } -sub register_patch { - my ($self, $dir, $tmpdiff, $patch_name) = @_; +sub _add_line { + my ($file, $line) = @_; - sub add_line { - my ($file, $line) = @_; - open(my $file_fh, ">>", $file) || syserr(_g("cannot write %s"), $file); - print $file_fh "$line\n"; - close($file_fh); - } + open(my $file_fh, ">>", $file) || syserr(_g("cannot write %s"), $file); + print $file_fh "$line\n"; + close($file_fh); +} - sub drop_line { - my ($file, $re) = @_; - open(my $file_fh, "<", $file) || syserr(_g("cannot read %s"), $file); - my @lines = <$file_fh>; - close($file_fh); - open($file_fh, ">", $file) || syserr(_g("cannot write %s"), $file); - print($file_fh $_) foreach grep { not /^\Q$re\E\s*$/ } @lines; - close($file_fh); - } +sub _drop_line { + my ($file, $re) = @_; + + open(my $file_fh, "<", $file) || syserr(_g("cannot read %s"), $file); + my @lines = <$file_fh>; + close($file_fh); + open($file_fh, ">", $file) || syserr(_g("cannot write %s"), $file); + print($file_fh $_) foreach grep { not /^\Q$re\E\s*$/ } @lines; + close($file_fh); +} + +sub register_patch { + my ($self, $dir, $tmpdiff, $patch_name) = @_; my $quilt = $self->build_quilt_object($dir); @@ -255,8 +257,8 @@ sub register_patch { $quilt->setup_db(); # Add patch to series file if (not $has_patch) { - add_line($series, $patch_name); - add_line($applied, $patch_name); + _add_line($series, $patch_name); + _add_line($applied, $patch_name); $quilt->load_series(); $quilt->load_db(); } @@ -268,8 +270,8 @@ sub register_patch { } else { # Remove auto_patch from series if ($has_patch) { - drop_line($series, $patch_name); - drop_line($applied, $patch_name); + _drop_line($series, $patch_name); + _drop_line($applied, $patch_name); erasedir($quilt->get_db_file($patch_name)); $quilt->load_db(); $quilt->load_series(); diff --git a/scripts/Dpkg/Source/Patch.pm b/scripts/Dpkg/Source/Patch.pm index bca644269..104bde6d8 100644 --- a/scripts/Dpkg/Source/Patch.pm +++ b/scripts/Dpkg/Source/Patch.pm @@ -310,6 +310,63 @@ sub _fail_not_same_type { $self->register_error(); } +sub _getline { + my $handle = shift; + + my $line = <$handle>; + if (defined $line) { + # Strip end-of-line chars + chomp($line); + $line =~ s/\r$//; + } + return $line; +} + +# Strip timestamp +sub _strip_ts { + my $header = shift; + + # Tab is the official separator, it's always used when + # filename contain spaces. Try it first, otherwise strip on space + # if there's no tab + $header =~ s/\s.*// unless ($header =~ s/\t.*//); + return $header; +} + +sub _intuit_file_patched { + my ($old, $new) = @_; + + return $new unless defined $old; + return $old unless defined $new; + return $new if -e $new and not -e $old; + return $old if -e $old and not -e $new; + + # We don't consider the case where both files are non-existent and + # where patch picks the one with the fewest directories to create + # since dpkg-source will pre-create the required directories + + # Precalculate metrics used by patch + my ($tmp_o, $tmp_n) = ($old, $new); + my ($len_o, $len_n) = (length($old), length($new)); + $tmp_o =~ s{[/\\]+}{/}g; + $tmp_n =~ s{[/\\]+}{/}g; + my $nb_comp_o = ($tmp_o =~ tr{/}{/}); + my $nb_comp_n = ($tmp_n =~ tr{/}{/}); + $tmp_o =~ s{^.*/}{}; + $tmp_n =~ s{^.*/}{}; + my ($blen_o, $blen_n) = (length($tmp_o), length($tmp_n)); + + # Decide like patch would + if ($nb_comp_o != $nb_comp_n) { + return ($nb_comp_o < $nb_comp_n) ? $old : $new; + } elsif ($blen_o != $blen_n) { + return ($blen_o < $blen_n) ? $old : $new; + } elsif ($len_o != $len_n) { + return ($len_o < $len_n) ? $old : $new; + } + return $old; +} + # check diff for sanity, find directories to create as a side effect sub analyze { my ($self, $destdir, %opts) = @_; @@ -322,55 +379,7 @@ sub analyze { my $patch_header = ''; my $diff_count = 0; - sub getline { - my $handle = shift; - my $line = <$handle>; - if (defined $line) { - # Strip end-of-line chars - chomp($line); - $line =~ s/\r$//; - } - return $line; - } - sub strip_ts { # Strip timestamp - my $header = shift; - # Tab is the official separator, it's always used when - # filename contain spaces. Try it first, otherwise strip on space - # if there's no tab - $header =~ s/\s.*// unless ($header =~ s/\t.*//); - return $header; - } - sub intuit_file_patched { - my ($old, $new) = @_; - return $new unless defined $old; - return $old unless defined $new; - return $new if -e $new and not -e $old; - return $old if -e $old and not -e $new; - # We don't consider the case where both files are non-existent and - # where patch picks the one with the fewest directories to create - # since dpkg-source will pre-create the required directories - # - # Precalculate metrics used by patch - my ($tmp_o, $tmp_n) = ($old, $new); - my ($len_o, $len_n) = (length($old), length($new)); - $tmp_o =~ s{[/\\]+}{/}g; - $tmp_n =~ s{[/\\]+}{/}g; - my $nb_comp_o = ($tmp_o =~ tr{/}{/}); - my $nb_comp_n = ($tmp_n =~ tr{/}{/}); - $tmp_o =~ s{^.*/}{}; - $tmp_n =~ s{^.*/}{}; - my ($blen_o, $blen_n) = (length($tmp_o), length($tmp_n)); - # Decide like patch would - if ($nb_comp_o != $nb_comp_n) { - return ($nb_comp_o < $nb_comp_n) ? $old : $new; - } elsif ($blen_o != $blen_n) { - return ($blen_o < $blen_n) ? $old : $new; - } elsif ($len_o != $len_n) { - return ($len_o < $len_n) ? $old : $new; - } - return $old; - } - $_ = getline($self); + $_ = _getline($self); HUNK: while (defined($_) || not eof($self)) { @@ -382,26 +391,26 @@ sub analyze { } else { $patch_header .= "$_\n"; } - last HUNK if not defined($_ = getline($self)); + last HUNK if not defined($_ = _getline($self)); } $diff_count++; # read file header (---/+++ pair) unless(s/^--- //) { error(_g("expected ^--- in line %d of diff `%s'"), $., $diff); } - $path{'old'} = $_ = strip_ts($_); + $path{'old'} = $_ = _strip_ts($_); $fn{'old'} = $_ if $_ ne '/dev/null' and s{^[^/]*/+}{$destdir/}; if (/\.dpkg-orig$/) { error(_g("diff `%s' patches file with name ending .dpkg-orig"), $diff); } - unless (defined($_ = getline($self))) { + unless (defined($_ = _getline($self))) { error(_g("diff `%s' finishes in middle of ---/+++ (line %d)"), $diff, $.); } unless (s/^\+\+\+ //) { error(_g("line after --- isn't as expected in diff `%s' (line %d)"), $diff, $.); } - $path{'new'} = $_ = strip_ts($_); + $path{'new'} = $_ = _strip_ts($_); $fn{'new'} = $_ if $_ ne '/dev/null' and s{^[^/]*/+}{$destdir/}; unless (defined $fn{'old'} or defined $fn{'new'}) { @@ -437,7 +446,7 @@ sub analyze { $diff, $fn{'old'}, $.) unless -e $fn{'old'}; } } - my $fn = intuit_file_patched($fn{'old'}, $fn{'new'}); + my $fn = _intuit_file_patched($fn{'old'}, $fn{'new'}); my $dirname = $fn; if ($dirname =~ s{/[^/]+$}{} && not -d $dirname) { @@ -458,14 +467,14 @@ sub analyze { # read hunks my $hunk = 0; - while (defined($_ = getline($self))) { + while (defined($_ = _getline($self))) { # read hunk header (@@) next if /^\\ /; last unless (/^@@ -\d+(,(\d+))? \+\d+(,(\d+))? @\@( .*)?$/); my ($olines, $nlines) = ($1 ? $2 : 1, $3 ? $4 : 1); # read hunk while ($olines || $nlines) { - unless (defined($_ = getline($self))) { + unless (defined($_ = _getline($self))) { if (($olines == $nlines) and ($olines < 3)) { warning(_g("unexpected end of diff `%s'"), $diff) if $opts{"verbose"}; diff --git a/scripts/Dpkg/Version.pm b/scripts/Dpkg/Version.pm index d4944c80e..2957404b5 100644 --- a/scripts/Dpkg/Version.pm +++ b/scripts/Dpkg/Version.pm @@ -281,21 +281,23 @@ of the character is used to sort between characters. =cut -sub version_compare_string($$) { - sub order { - my ($x) = @_; - if ($x eq '~') { - return -1; - } elsif ($x =~ /^\d$/) { - return $x * 1 + 1; - } elsif ($x =~ /^[A-Za-z]$/) { - return ord($x); - } else { - return ord($x) + 256; - } +sub _version_order { + my ($x) = @_; + + if ($x eq '~') { + return -1; + } elsif ($x =~ /^\d$/) { + return $x * 1 + 1; + } elsif ($x =~ /^[A-Za-z]$/) { + return ord($x); + } else { + return ord($x) + 256; } - my @a = map(order($_), split(//, shift)); - my @b = map(order($_), split(//, shift)); +} + +sub version_compare_string($$) { + my @a = map(_version_order($_), split(//, shift)); + my @b = map(_version_order($_), split(//, shift)); while (1) { my ($a, $b) = (shift @a, shift @b); return 0 if not defined($a) and not defined($b); diff --git a/test/100_critic.t b/test/100_critic.t index fd62ad9cc..3e91080f2 100644 --- a/test/100_critic.t +++ b/test/100_critic.t @@ -62,6 +62,7 @@ my @policies = qw( Modules::RequireExplicitPackage Modules::RequireFilenameMatchesPackage Subroutines::ProhibitExplicitReturnUndef + Subroutines::ProhibitNestedSubs TestingAndDebugging::ProhibitNoStrict TestingAndDebugging::ProhibitNoWarnings TestingAndDebugging::RequireUseStrict |