mirror of https://gitee.com/openkylin/lintian.git
879 lines
22 KiB
Perl
879 lines
22 KiB
Perl
# -*- perl -*- Lintian::Index
|
|
#
|
|
# Copyright (C) 2020 Felix Lechner
|
|
#
|
|
# This program is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License as published by the Free
|
|
# Software Foundation; either version 2 of the License, or (at your option)
|
|
# any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful, but WITHOUT
|
|
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
|
|
# more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License along with
|
|
# this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
package Lintian::Index;
|
|
|
|
use v5.20;
|
|
use warnings;
|
|
use utf8;
|
|
|
|
use Carp;
|
|
use Const::Fast;
|
|
use Cwd;
|
|
use IPC::Run3;
|
|
use List::SomeUtils qw(any);
|
|
use Path::Tiny;
|
|
use Unicode::UTF8 qw(encode_utf8 decode_utf8);
|
|
|
|
use Lintian::Index::Item;
|
|
use Lintian::IO::Select qw(unpack_and_index_piped_tar);
|
|
use Lintian::IPC::Run3 qw(safe_qx);
|
|
|
|
use Lintian::Util qw(perm2oct);
|
|
|
|
const my $EMPTY => q{};
|
|
const my $SPACE => q{ };
|
|
const my $SLASH => q{/};
|
|
const my $BACKSLASH => q{\\};
|
|
const my $ZERO => q{0};
|
|
const my $HYPHEN => q{-};
|
|
const my $PERCENT => q{%};
|
|
const my $NEWLINE => qq{\n};
|
|
|
|
const my $WAIT_STATUS_SHIFT => 8;
|
|
const my $NO_LIMIT => -1;
|
|
const my $LINES_PER_FILE => 3;
|
|
const my $WIDELY_READABLE_FOLDER => oct(755);
|
|
const my $WORLD_WRITABLE_FOLDER => oct(777);
|
|
|
|
use Moo;
|
|
use namespace::clean;
|
|
|
|
with
|
|
'Lintian::Index::Ar',
|
|
'Lintian::Index::Elf',
|
|
'Lintian::Index::FileTypes',
|
|
'Lintian::Index::Java',
|
|
'Lintian::Index::Md5sums',
|
|
'Lintian::Index::Strings';
|
|
|
|
my %FILE_CODE2LPATH_TYPE = (
|
|
$HYPHEN => Lintian::Index::Item::TYPE_FILE
|
|
| Lintian::Index::Item::OPEN_IS_OK,
|
|
'h' => Lintian::Index::Item::TYPE_HARDLINK
|
|
| Lintian::Index::Item::OPEN_IS_OK,
|
|
'd' => Lintian::Index::Item::TYPE_DIR| Lintian::Index::Item::FS_PATH_IS_OK,
|
|
'l' => Lintian::Index::Item::TYPE_SYMLINK,
|
|
'b' => Lintian::Index::Item::TYPE_BLOCK_DEV,
|
|
'c' => Lintian::Index::Item::TYPE_CHAR_DEV,
|
|
'p' => Lintian::Index::Item::TYPE_PIPE,
|
|
);
|
|
|
|
=head1 NAME
|
|
|
|
Lintian::Index - access to collected data about the upstream (orig) sources
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Lintian::Index;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Lintian::Processable::Source::Orig::Index provides an interface to collected data about the upstream (orig) sources.
|
|
|
|
=head1 INSTANCE METHODS
|
|
|
|
=over 4
|
|
|
|
=item identifier
|
|
|
|
=item catalog
|
|
|
|
Returns a reference to a hash with elements catalogued by path names.
|
|
|
|
=item C<basedir>
|
|
|
|
Returns the base directory for file references.
|
|
|
|
=item C<anchored>
|
|
|
|
=item unpack_messages
|
|
|
|
=cut
|
|
|
|
has identifier => (is => 'rw', default => 'unnamed');
|
|
|
|
has catalog => (
|
|
is => 'rw',
|
|
default => sub {
|
|
my ($self) = @_;
|
|
|
|
# create an empty root
|
|
my $root = Lintian::Index::Item->new;
|
|
|
|
# associate with this index
|
|
$root->index($self);
|
|
|
|
my %catalog;
|
|
$catalog{$EMPTY} = $root;
|
|
|
|
return \%catalog;
|
|
}
|
|
);
|
|
|
|
has basedir => (
|
|
is => 'rw',
|
|
trigger => sub {
|
|
my ($self, $folder) = @_;
|
|
|
|
return
|
|
unless length $folder;
|
|
|
|
# create directory
|
|
path($folder)->mkpath({ chmod => $WORLD_WRITABLE_FOLDER })
|
|
unless -e $folder;
|
|
},
|
|
default => $EMPTY
|
|
);
|
|
|
|
has anchored => (is => 'rw', default => 0);
|
|
has unpack_messages => (is => 'rw', default => sub { [] });
|
|
|
|
has sorted_list => (
|
|
is => 'ro',
|
|
lazy => 1,
|
|
default => sub {
|
|
my ($self) = @_;
|
|
|
|
my @sorted = sort { $a->name cmp $b->name } values %{$self->catalog};
|
|
|
|
# remove automatic root dir; list is sorted
|
|
shift @sorted;
|
|
|
|
const my @IMMUTABLE => @sorted;
|
|
|
|
return \@IMMUTABLE;
|
|
}
|
|
);
|
|
|
|
=item lookup (FILE)
|
|
|
|
Like L</index> except orig_index is based on the "orig tarballs" of
|
|
the source packages.
|
|
|
|
For native packages L</index> and L</orig_index> are generally
|
|
identical.
|
|
|
|
NB: If sorted_index includes a debian packaging, it is was
|
|
contained in upstream part of the source package (or the package is
|
|
native).
|
|
|
|
=cut
|
|
|
|
sub lookup {
|
|
my ($self, $name) = @_;
|
|
|
|
# get root dir by default
|
|
$name //= $EMPTY;
|
|
|
|
croak encode_utf8($self->identifier . ': Name is not a string')
|
|
unless ref $name eq $EMPTY;
|
|
|
|
my $found = $self->catalog->{$name};
|
|
|
|
return $found
|
|
if defined $found;
|
|
|
|
return undef;
|
|
}
|
|
|
|
=item resolve_path
|
|
|
|
=cut
|
|
|
|
sub resolve_path {
|
|
my ($self, $name) = @_;
|
|
|
|
return $self->lookup->resolve_path($name);
|
|
}
|
|
|
|
=item create_from_basedir
|
|
|
|
=cut
|
|
|
|
sub create_from_basedir {
|
|
my ($self) = @_;
|
|
|
|
my $savedir = getcwd;
|
|
chdir($self->basedir)
|
|
or die encode_utf8(
|
|
$self->identifier . ': Cannot change to directory ' . $self->basedir);
|
|
|
|
# get times in UTC
|
|
my $TIME_STAMP
|
|
= $PERCENT . q{M} . $SPACE . $PERCENT . q{s} . $SPACE . $PERCENT . q{A+};
|
|
my $FILE_NAME = $PERCENT . q{p};
|
|
my $LINK_DESTINATION = $PERCENT . q{l};
|
|
my $NULL_BREAK = $BACKSLASH . $ZERO;
|
|
|
|
my @REQUESTED_FIELDS
|
|
= map { $_ . $NULL_BREAK } ($TIME_STAMP, $FILE_NAME, $LINK_DESTINATION);
|
|
|
|
my @index_command
|
|
= ('env', 'TZ=UTC', 'find', '-printf', join($EMPTY, @REQUESTED_FIELDS));
|
|
my $index_output;
|
|
my $index_errors;
|
|
|
|
run3(\@index_command, \undef, \$index_output, \$index_errors);
|
|
|
|
chdir($savedir)
|
|
or die encode_utf8(
|
|
$self->identifier . ": Cannot change to directory $savedir");
|
|
|
|
# allow processing of file names with non UTF-8 bytes
|
|
$index_errors = decode_utf8($index_errors)
|
|
if length $index_errors;
|
|
|
|
my $permissionspattern = qr/\S{10}/;
|
|
my $sizepattern = qr/\d+/;
|
|
my $datepattern = qr/\d{4}-\d{2}-\d{2}/;
|
|
my $timepattern = qr/\d{2}:\d{2}:\d{2}\.\d+/;
|
|
my $pathpattern = qr/[^\0]*/;
|
|
|
|
my %all;
|
|
|
|
$index_output =~ s/\0$//;
|
|
|
|
my @lines = split(/\0/, $index_output, $NO_LIMIT);
|
|
die encode_utf8($self->identifier
|
|
. ": Did not get a multiple of $LINES_PER_FILE lines from find.")
|
|
unless @lines % $LINES_PER_FILE == 0;
|
|
|
|
while (defined(my $first = shift @lines)) {
|
|
|
|
my $entry = Lintian::Index::Item->new;
|
|
$entry->index($self);
|
|
|
|
$first
|
|
=~ /^($permissionspattern)\ ($sizepattern)\ ($datepattern)\+($timepattern)$/s;
|
|
|
|
$entry->perm($1);
|
|
$entry->size($2);
|
|
$entry->date($3);
|
|
$entry->time($4);
|
|
|
|
my $name = shift @lines;
|
|
|
|
my $linktarget = shift @lines;
|
|
|
|
# for non-links, string is empty
|
|
$entry->link($linktarget)
|
|
if length $linktarget;
|
|
|
|
# find prints single dot for base; removed in next step
|
|
$name =~ s{^\.$}{\./}s;
|
|
|
|
# strip relative prefix
|
|
$name =~ s{^\./+}{}s;
|
|
|
|
# make sure directories end with a slash, except root
|
|
$name .= $SLASH
|
|
if length $name
|
|
&& $entry->perm =~ /^d/
|
|
&& $name !~ m{ /$ }msx;
|
|
$entry->name($name);
|
|
|
|
$all{$entry->name} = $entry;
|
|
}
|
|
|
|
$self->catalog(\%all);
|
|
|
|
my $load_errors = $self->load;
|
|
|
|
return $index_errors . $load_errors;
|
|
}
|
|
|
|
=item create_from_piped_tar
|
|
|
|
=cut
|
|
|
|
sub create_from_piped_tar {
|
|
my ($self, $command) = @_;
|
|
|
|
my $extract_dir = $self->basedir;
|
|
|
|
my ($named, $numeric, $extract_errors, $index_errors)
|
|
= unpack_and_index_piped_tar($command, $extract_dir);
|
|
|
|
# fix permissions
|
|
safe_qx('chmod', '-R', 'u+rwX,go-w', $extract_dir);
|
|
|
|
# allow processing of file names with non UTF-8 bytes
|
|
my @named_owner = split(/\n/, $named);
|
|
my @numeric_owner = split(/\n/, $numeric);
|
|
|
|
my %catalog;
|
|
|
|
for my $line (@named_owner) {
|
|
|
|
my $entry = Lintian::Index::Item->new;
|
|
$entry->init_from_tar_output($line);
|
|
$entry->index($self);
|
|
|
|
$catalog{$entry->name} = $entry;
|
|
}
|
|
|
|
# get numerical owners from second list
|
|
for my $line (@numeric_owner) {
|
|
|
|
# entry not used outside this loop
|
|
my $entry = Lintian::Index::Item->new;
|
|
$entry->init_from_tar_output($line);
|
|
|
|
die encode_utf8($self->identifier
|
|
. ': Numerical index lists extra files for file name '
|
|
. $entry->name)
|
|
unless exists $catalog{$entry->name};
|
|
|
|
# keep numerical uid and gid
|
|
$catalog{$entry->name}->uid($entry->owner);
|
|
$catalog{$entry->name}->gid($entry->group);
|
|
}
|
|
|
|
# tar produces spurious root entry when stripping slashes from member names
|
|
delete $catalog{$SLASH}
|
|
unless $self->anchored;
|
|
|
|
$self->catalog(\%catalog);
|
|
|
|
my $load_errors = $self->load;
|
|
|
|
return $extract_errors . $index_errors . $load_errors;
|
|
}
|
|
|
|
=item load
|
|
|
|
=cut
|
|
|
|
sub load {
|
|
my ($self) = @_;
|
|
|
|
my $errors = $EMPTY;
|
|
|
|
my %all = %{$self->catalog};
|
|
|
|
# set internal permissions flags
|
|
for my $entry (values %all) {
|
|
|
|
my $raw_type = substr($entry->perm, 0, 1);
|
|
|
|
my $operm = perm2oct($entry->perm);
|
|
$entry->path_info(
|
|
$operm | (
|
|
$FILE_CODE2LPATH_TYPE{$raw_type}
|
|
// Lintian::Index::Item::TYPE_OTHER
|
|
)
|
|
);
|
|
}
|
|
|
|
# find all entries that are not regular files
|
|
my @nosize
|
|
= grep { !$_->path_info & Lintian::Index::Item::TYPE_FILE } values %all;
|
|
|
|
# reset size for anything but regular files
|
|
$_->size(0) for @nosize;
|
|
|
|
if ($self->anchored) {
|
|
|
|
my %relative;
|
|
for my $name (keys %all) {
|
|
my $entry = $all{$name};
|
|
|
|
# remove leading slash from absolute names
|
|
my $name = $entry->name;
|
|
$name =~ s{^/+}{}s;
|
|
$entry->name($name);
|
|
|
|
# remove leading slash from absolute hardlink targets
|
|
if ($entry->is_hardlink) {
|
|
my $target = $entry->link;
|
|
$target =~ s{^/+}{}s;
|
|
$entry->link($target);
|
|
}
|
|
|
|
$relative{$name} = $entry;
|
|
}
|
|
|
|
%all = %relative;
|
|
}
|
|
|
|
# disallow absolute names
|
|
die encode_utf8($self->identifier . ': Index contains absolute path names')
|
|
if any { $_->name =~ m{^/}s } values %all;
|
|
|
|
# disallow absolute hardlink targets
|
|
die encode_utf8(
|
|
$self->identifier . ': Index contains absolute hardlink targets')
|
|
if any { $_->link =~ m{^/}s } grep { $_->is_hardlink } values %all;
|
|
|
|
# add entries for missing directories
|
|
for my $entry (values %all) {
|
|
|
|
my $current = $entry;
|
|
my $parentname;
|
|
|
|
# travel up the directory tree
|
|
do {
|
|
$parentname = $current->dirname;
|
|
|
|
# insert new entry for missing intermediate directories
|
|
unless (exists $all{$parentname}) {
|
|
|
|
my $added = Lintian::Index::Item->new;
|
|
$added->index($self);
|
|
|
|
$added->name($parentname);
|
|
$added->path_info(
|
|
$FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER);
|
|
|
|
# random but fixed date; hint, it's a good read. :)
|
|
$added->date('1998-01-25');
|
|
$added->time('22:55:34');
|
|
$added->faux(1);
|
|
|
|
$all{$parentname} = $added;
|
|
}
|
|
|
|
$current = $all{$parentname};
|
|
|
|
} while ($parentname ne $EMPTY);
|
|
}
|
|
|
|
# insert root for empty tarfies like suckless-tools_45.orig.tar.xz
|
|
unless (exists $all{$EMPTY}) {
|
|
|
|
my $root = Lintian::Index::Item->new;
|
|
$root->index($self);
|
|
|
|
$root->name($EMPTY);
|
|
$root->path_info($FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER);
|
|
|
|
# random but fixed date; hint, it's a good read. :)
|
|
$root->date('1998-01-25');
|
|
$root->time('22:55:34');
|
|
$root->faux(1);
|
|
|
|
$all{$EMPTY} = $root;
|
|
}
|
|
|
|
my @directories
|
|
= grep { $_->path_info & Lintian::Index::Item::TYPE_DIR } values %all;
|
|
|
|
# make space for children
|
|
my %children;
|
|
$children{$_->name} = [] for @directories;
|
|
|
|
# record children
|
|
for my $entry (values %all) {
|
|
|
|
my $parentname = $entry->dirname;
|
|
|
|
# Ensure the "root" is not its own child. It is not really helpful
|
|
# from an analysis PoV and it creates ref cycles (and by extension
|
|
# leaks like #695866).
|
|
push(@{ $children{$parentname} }, $entry)
|
|
unless $parentname eq $entry->name;
|
|
}
|
|
|
|
foreach my $entry (@directories) {
|
|
my %childnames
|
|
= map {$_->basename => $_->name }@{ $children{$entry->name} };
|
|
$entry->childnames(\%childnames);
|
|
}
|
|
|
|
# ensure root is not its own child; may create leaks like #695866
|
|
die encode_utf8($self->identifier . ': Root directory is its own parent')
|
|
if defined $all{$EMPTY} && defined $all{$EMPTY}->parent_dir;
|
|
|
|
# find all hard links
|
|
my @hardlinks
|
|
= grep { $_->path_info & Lintian::Index::Item::TYPE_HARDLINK }
|
|
values %all;
|
|
|
|
# catalog where they point
|
|
my %backlinks;
|
|
push(@{$backlinks{$_->link}}, $_) for @hardlinks;
|
|
|
|
# add the master files for proper sort results
|
|
push(@{$backlinks{$_}}, $all{$_}) for keys %backlinks;
|
|
|
|
# point hard links to shortest path
|
|
for my $mastername (keys %backlinks) {
|
|
|
|
my @group = @{$backlinks{$mastername}};
|
|
|
|
# sort for path length
|
|
my @links = sort { $a->name cmp $b->name } @group;
|
|
|
|
# pick the shortest path
|
|
my $preferred = shift @links;
|
|
|
|
# get the previous master entry
|
|
my $master = $all{$mastername};
|
|
|
|
# skip if done
|
|
next
|
|
if $preferred->name eq $master->name;
|
|
|
|
# unset link for preferred
|
|
$preferred->link($EMPTY);
|
|
|
|
# copy size from original
|
|
$preferred->size($master->size);
|
|
|
|
$preferred->path_info(
|
|
($preferred->path_info& ~Lintian::Index::Item::TYPE_HARDLINK)
|
|
| Lintian::Index::Item::TYPE_FILE);
|
|
|
|
foreach my $pointer (@links) {
|
|
|
|
# turn into a hard link
|
|
$pointer->path_info(
|
|
($pointer->path_info & ~Lintian::Index::Item::TYPE_FILE)
|
|
| Lintian::Index::Item::TYPE_HARDLINK);
|
|
|
|
# set link to preferred path
|
|
$pointer->link($preferred->name);
|
|
|
|
# no size for hardlinks
|
|
$pointer->size(0);
|
|
}
|
|
}
|
|
|
|
# make sure recorded names match hash keys
|
|
$all{$_}->name($_) for keys %all;
|
|
|
|
$self->catalog(\%all);
|
|
|
|
$errors .= $self->add_md5sums;
|
|
$errors .= $self->add_file_types;
|
|
|
|
$errors .= $self->add_ar;
|
|
$errors .= $self->add_elf;
|
|
$errors .= $self->add_java;
|
|
$errors .= $self->add_strings;
|
|
|
|
return $errors;
|
|
}
|
|
|
|
=item merge_in
|
|
|
|
=cut
|
|
|
|
sub merge_in {
|
|
my ($self, $other) = @_;
|
|
|
|
die encode_utf8($self->identifier
|
|
. ': Need same base directory ('
|
|
. $self->basedir . ' vs '
|
|
. $other->basedir . ')')
|
|
unless $self->basedir eq $other->basedir;
|
|
|
|
die encode_utf8($self->identifier . ': Need same anchoring status')
|
|
unless $self->anchored == $other->anchored;
|
|
|
|
# associate all new items with this index
|
|
$_->index($self) for values %{$other->catalog};
|
|
|
|
for my $item (values %{$other->catalog}) {
|
|
|
|
# do not transfer root
|
|
next
|
|
if $item->name eq $EMPTY;
|
|
|
|
# duplicates on disk are dropped with basedir segments
|
|
$self->catalog->{$item->name} = $item;
|
|
|
|
# when adding folder, delete potential file entry
|
|
my $noslash = $item->name;
|
|
if ($noslash =~ s{/$}{}) {
|
|
delete $self->catalog->{$noslash};
|
|
}
|
|
}
|
|
|
|
# add children that came from other root to current
|
|
my @other_childnames = keys %{$other->catalog->{$EMPTY}->childnames};
|
|
for my $name (@other_childnames) {
|
|
|
|
$self->catalog->{$EMPTY}->childnames->{$name}
|
|
= $self->catalog->{$name};
|
|
}
|
|
|
|
# remove items from other index
|
|
$other->catalog({});
|
|
|
|
# unset other base directory
|
|
$other->basedir($EMPTY);
|
|
|
|
return;
|
|
}
|
|
|
|
=item capture_common_prefix
|
|
|
|
=cut
|
|
|
|
sub capture_common_prefix {
|
|
my ($self) = @_;
|
|
|
|
my $new_basedir = path($self->basedir)->parent;
|
|
|
|
# do nothing in root
|
|
return
|
|
if $new_basedir eq $SLASH;
|
|
|
|
my $segment = path($self->basedir)->basename;
|
|
die encode_utf8($self->identifier . ': Common path segment has no length')
|
|
unless length $segment;
|
|
|
|
my $prefix;
|
|
if ($self->anchored) {
|
|
$prefix = $SLASH . $segment;
|
|
} else {
|
|
$prefix = $segment . $SLASH;
|
|
}
|
|
|
|
my $new_root = Lintian::Index::Item->new;
|
|
|
|
# associate new item with this index
|
|
$new_root->index($self);
|
|
|
|
$new_root->name($EMPTY);
|
|
$new_root->childnames({ $segment => $prefix });
|
|
|
|
# random but fixed date; hint, it's a good read. :)
|
|
$new_root->date('1998-01-25');
|
|
$new_root->time('22:55:34');
|
|
$new_root->path_info($FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER);
|
|
$new_root->faux(1);
|
|
|
|
my %new_catalog;
|
|
for my $item (values %{$self->catalog}) {
|
|
|
|
# drop common prefix from name
|
|
my $new_name = $prefix . $item->name;
|
|
$item->name($new_name);
|
|
|
|
if (length $item->link) {
|
|
|
|
# add common prefix from link target
|
|
my $new_link = $prefix . $item->link;
|
|
$item->link($new_link);
|
|
}
|
|
|
|
# adjust references to children
|
|
for my $basename (keys %{$item->childnames}) {
|
|
$item->childnames->{$basename}
|
|
= $prefix . $item->childnames->{$basename};
|
|
}
|
|
|
|
$new_catalog{$new_name} = $item;
|
|
}
|
|
|
|
$new_catalog{$EMPTY} = $new_root;
|
|
$new_catalog{$prefix}->parent_dir($new_root);
|
|
|
|
$self->catalog(\%new_catalog);
|
|
|
|
# remove segment from base directory
|
|
$self->basedir($new_basedir);
|
|
|
|
return;
|
|
}
|
|
|
|
=item drop_common_prefix
|
|
|
|
=cut
|
|
|
|
sub drop_common_prefix {
|
|
my ($self) = @_;
|
|
|
|
my $errors = $EMPTY;
|
|
|
|
my @childnames = keys %{$self->catalog->{$EMPTY}->childnames};
|
|
|
|
die encode_utf8($self->identifier . ': Not exactly one top-level child')
|
|
unless @childnames == 1;
|
|
|
|
my $segment = $childnames[0];
|
|
die encode_utf8($self->identifier . ': Common path segment has no length')
|
|
unless length $segment;
|
|
|
|
my $new_root = $self->lookup($segment . $SLASH);
|
|
die encode_utf8($self->identifier . ': New root is not a directory')
|
|
unless $new_root->is_dir;
|
|
|
|
my $prefix;
|
|
if ($self->anchored) {
|
|
$prefix = $SLASH . $segment;
|
|
} else {
|
|
$prefix = $segment . $SLASH;
|
|
}
|
|
|
|
my $regex = quotemeta($prefix);
|
|
|
|
delete $self->catalog->{$EMPTY};
|
|
|
|
my %new_catalog;
|
|
for my $item (values %{$self->catalog}) {
|
|
|
|
# drop common prefix from name
|
|
my $new_name = $item->name;
|
|
$new_name =~ s{^$regex}{};
|
|
$item->name($new_name);
|
|
|
|
if (length $item->link) {
|
|
|
|
# drop common prefix from link target
|
|
my $new_link = $item->link;
|
|
$new_link =~ s{^$regex}{};
|
|
$item->link($new_link);
|
|
}
|
|
|
|
# adjust references to children
|
|
for my $basename (keys %{$item->childnames}) {
|
|
$item->childnames->{$basename} =~ s{^$regex}{};
|
|
}
|
|
|
|
# unsure this works, but orig not anchored
|
|
$new_name = $EMPTY
|
|
if $new_name eq $SLASH && $self->anchored;
|
|
|
|
$new_catalog{$new_name} = $item;
|
|
}
|
|
|
|
$self->catalog(\%new_catalog);
|
|
|
|
# add dropped segment to base directory
|
|
$self->basedir($self->basedir . $SLASH . $segment);
|
|
|
|
my $other_errors = $self->drop_basedir_segment;
|
|
|
|
return $errors . $other_errors;
|
|
}
|
|
|
|
=item drop_basedir_segment
|
|
|
|
=cut
|
|
|
|
sub drop_basedir_segment {
|
|
my ($self) = @_;
|
|
|
|
my $errors = $EMPTY;
|
|
|
|
my $obsolete = path($self->basedir)->basename;
|
|
die encode_utf8($self->identifier . ': Base directory has no name')
|
|
unless length $obsolete;
|
|
|
|
my $parent_dir = path($self->basedir)->parent->stringify;
|
|
die encode_utf8($self->identifier . ': Base directory has no parent')
|
|
if $parent_dir eq $SLASH;
|
|
|
|
my $grandparent_dir = path($parent_dir)->parent->stringify;
|
|
die encode_utf8(
|
|
$self->identifier . ': Will not do anything in file system root')
|
|
if $grandparent_dir eq $SLASH;
|
|
|
|
# destroyed when object is lost
|
|
my $tempdir_tiny
|
|
= path($grandparent_dir)->tempdir(TEMPLATE => 'customXXXXXXXX');
|
|
|
|
my $tempdir = $tempdir_tiny->stringify;
|
|
|
|
# avoids conflict in case of repeating path segments
|
|
for my $child (path($self->basedir)->children) {
|
|
my $old_name = $child->stringify;
|
|
|
|
# Perl unicode bug
|
|
utf8::downgrade $old_name;
|
|
utf8::downgrade $tempdir;
|
|
|
|
my @command = ('mv', $old_name, $tempdir);
|
|
my $stderr;
|
|
run3(\@command, \undef, \undef, \$stderr);
|
|
my $status = ($? >> $WAIT_STATUS_SHIFT);
|
|
|
|
# already in UTF-8
|
|
die $stderr
|
|
if $status;
|
|
}
|
|
|
|
rmdir $self->basedir;
|
|
$self->basedir($parent_dir);
|
|
|
|
for my $child ($tempdir_tiny->children) {
|
|
my $old_name = $child->stringify;
|
|
|
|
my $target_dir = $parent_dir . $SLASH . $child->basename;
|
|
|
|
# Perl unicode bug
|
|
utf8::downgrade $target_dir;
|
|
|
|
if (-e $target_dir) {
|
|
|
|
# catalog items were dropped when index was merged
|
|
my @command = (qw{rm -rf}, $target_dir);
|
|
my $stderr;
|
|
run3(\@command, \undef, \undef, \$stderr);
|
|
my $status = ($? >> $WAIT_STATUS_SHIFT);
|
|
|
|
# already in UTF-8
|
|
die $stderr
|
|
if $status;
|
|
|
|
my $display_dir
|
|
= path($parent_dir)->basename . $SLASH . $child->basename;
|
|
$errors .= "removed existing $display_dir" . $NEWLINE;
|
|
}
|
|
|
|
# Perl unicode bug
|
|
utf8::downgrade $old_name;
|
|
utf8::downgrade $parent_dir;
|
|
|
|
my @command = ('mv', $old_name, $parent_dir);
|
|
my $stderr;
|
|
run3(\@command, \undef, \undef, \$stderr);
|
|
my $status = ($? >> $WAIT_STATUS_SHIFT);
|
|
|
|
# already in UTF-8
|
|
die $stderr
|
|
if $status;
|
|
}
|
|
|
|
return $errors;
|
|
}
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Originally written by Felix Lechner <felix.lechner@lease-up.com> for
|
|
Lintian.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
lintian(1)
|
|
|
|
=cut
|
|
|
|
1;
|
|
|
|
# Local Variables:
|
|
# indent-tabs-mode: nil
|
|
# cperl-indent-level: 4
|
|
# End:
|
|
# vim: syntax=perl sw=4 sts=4 sr et
|