← Back to branch summary

~ubuntu-branches/debian/sid/libconfig-model-dpkg-perl/sid

« back to all changes in this revision

Viewing changes to lib/Config/Model/Dpkg/Copyright.pm

  • Committer: Package Import Robot
  • Author(s): Dominique Dumont
  • Date: 2015-07-03 20:13:44 UTC
  • Revision ID: package-import@ubuntu.com-20150703201344-5vaxte6d6xp1pi3e
Tags: 2.067
http://bugs.debian.org/789841
Major bug fixes release: previous version removed too many
directory entries. This version fixes this problem while being
able to merge existing directory entries with data extracted from
files (including LICENSE, COPYING or README files)

Also fixed:
* C::M::Dpkg::Dependency: escape '{' in regexp (Closes: #789841) ...
* Scanner::__squash_copyrights_years: also handle last entry of
  $copyrights_by_id...

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Config/Model/Dpkg/Copyright.pm
93
93
    #   is an integer index referencing
94
94
    #   an entry in @data to get the correct  copyright/license data
95
95
    # * %old_split_files contains paths no longer present. Useful to trace deleted files
 
96
 
 
97
    my $current_dir = $args{from_dir} || path('.');
 
98
 
 
99
    my %preserved_path;
 
100
    # warn about old files (data may be redundant or obsolete though)
 
101
    foreach my $old_path (sort keys %old_split_files) {
 
102
        # put back data matching an existing dir
 
103
        if ($old_path eq '*' or ($old_path =~ m!(.*)/\*$! and $current_dir->is_dir($1))) {
 
104
            $preserved_path{$old_path} = delete $old_split_files{$old_path};
 
105
        }
 
106
        else {
 
107
            say "Note: '$old_path' was removed from new upstream source";
 
108
        }
 
109
    }
 
110
 
 
111
    $self->_prune_old_dirs(\%new_split_files, \%old_split_files) ;
 
112
 
 
113
 
96
114
    # implode files entries with same data index
97
 
 
98
 
    __squash(\%new_split_files, \%old_split_files) ;
 
115
    __squash(\%new_split_files) ;
99
116
 
100
117
    # pack files by copyright id
101
118
    my @packed = __pack_files(\%new_split_files);
114
131
    # load new data in config tree
115
132
    foreach my $p (@packed) {
116
133
        my ($id, @paths) = $p->@*;
 
134
 
 
135
        if ($paths[0] =~ /\.$/) {
 
136
            if (@paths > 1) {
 
137
                die "Internal error: can't have dir path with file path: @paths";
 
138
            }
 
139
            my $p = $paths[0];
 
140
            $p =~ s/\.$/*/;
 
141
            my $old_data = delete $preserved_path{$p};
 
142
            say "old dir data for $p overridden" if $old_data;
 
143
            next;
 
144
        };
117
145
        my $datum = dclone($data[$id]);
118
146
        my $path_str = $self->normalize_path(\@paths);
119
147
        my $l = $datum->{License}{short_name};
159
187
            unless $global_lic_obj->fetch_with_id($l)->fetch_element_value('text');
160
188
    }
161
189
 
 
190
    # put back preserved data
 
191
    foreach my $old_path (sort keys %preserved_path) {
 
192
        say "Note: preserving entry '$old_path'" ;
 
193
        $files_obj->fetch_with_id($old_path)->load_data( $preserved_path{$old_path} );
 
194
    }
 
195
 
162
196
    # put back debian data
163
197
    foreach my $deb_path (sort keys %debian_paths) {
164
198
        $files_obj->fetch_with_id($deb_path)->load_data( $debian_paths{$deb_path} );
165
199
    }
166
200
 
167
 
    my $current_dir = $args{from_dir} || path('.');
168
 
 
169
 
    # warn about old files
170
 
    foreach my $old_path (sort keys %old_split_files) {
171
 
        # put back data matching an existing dir (data may be redundant or obsolete though)
172
 
        if ($old_path eq '*' or ($old_path =~ m!(.*)/\*$! and $current_dir->is_dir($1))) {
173
 
            say "Note: preserving entry '$old_path'";
174
 
            $files_obj->fetch_with_id($old_path)->load_data( $old_split_files{$old_path} );
175
 
        }
176
 
        else {
177
 
            say "Note: '$old_path' was removed from new upstream source";
178
 
        }
179
 
    }
180
 
 
181
201
    # read a debian/fix.scanned.copyright file to patch scanned data
182
202
    my $debian = $current_dir->child('debian'); # may be missing in test environment
183
203
    if ($debian->is_dir) {
196
216
    return ''; # improve returned message ?
197
217
}
198
218
 
 
219
sub _prune_old_dirs ($self, $h, $old_dirs, $path = [] ) {
 
220
 
 
221
    # recurse in the data structure
 
222
    foreach my $name (sort keys %$h) {
 
223
        my $item = $h->{$name};
 
224
        if (ref($item)) {
 
225
            $self->_prune_old_dirs($item, $old_dirs, [ $path->@*, $name ]);
 
226
        }
 
227
    }
 
228
 
 
229
    # delete current directory entry
 
230
    my $dir_path = join('/', $path->@*,'*');
 
231
    if ($old_dirs->{$dir_path}) {
 
232
        say "Removing old entry $dir_path";
 
233
        delete $old_dirs->{$dir_path};
 
234
    }
 
235
}
 
236
 
199
237
 
200
238
sub fill_global_license ($self, $l, $text) {
201
239