File: by-file.t

package info (click to toggle)
libconfig-model-dpkg-perl 3.014
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 3,200 kB
  • sloc: perl: 8,255; python: 242; makefile: 77; javascript: 16; sh: 1
file content (331 lines) | stat: -rw-r--r-- 13,857 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
use 5.20.0;
use strict;
use warnings;
use utf8;
use open ':std', ':encoding(utf8)';

use Test::More;
use Test::Differences;
use Test::Synopsis::Expectation;
use Software::Copyright;
use Path::Tiny;
use Log::Log4perl 1.11 qw(:easy :levels);
use List::MoreUtils qw/bsearch/;

use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;

require_ok('Dpkg::Copyright::Grant::ByFile');

Log::Log4perl->easy_init( $ERROR );

sub check_hash_consistency($grants, $label = '') {
    my $str = $label? "$label: " : '';
    foreach my $file (sort $grants->files) {
        my $hash = $grants->get_grant($file)->hash;
        my $ref = $grants->get_hash_files($hash);
        ok($ref, $str."file $file hash is found");
        my $found = bsearch { $_ cmp $file} $ref->@*;
        ok($found, $str."file $file and hash $hash match") if $ref;
    }

    foreach my $hash ($grants->hashes) {
        my @files = $grants->get_hash_files($hash)->@*;
        ok(scalar @files, $str."hash $hash has data");
        foreach my $file (@files) {
            my $grant = $grants->get_grant($file);
            if ($grant) {
                is($grant->hash, $hash, $str."$file hashes match");
            }
            else {
                fail($str."$file grant should not exist, hash data was not cleaned up");
            }
        }
    }
}

sub get_grant (%args) {
    return Dpkg::Copyright::Grant::ByFile->new(
        current_dir => path('.'),
        %args
    );
}

subtest "email propagation" => sub {
    my $grants = get_grant();

    $grants->add ('marcel.txt', 'GPL-2', '2012, Marcel');
    my $old_hash = $grants->get_grant('marcel.txt')->hash;

    # check that this grant is recorded in _owner_with_no_email attribute
    is($grants->get_owner("Marcel")->hash->[0], $old_hash , "check updated owner hash 1");

    $grants->add ('marcel2.txt', 'GPL-2', '2015, Marcel <marcel@example.com>');
    my $new_hash = $grants->get_grant('marcel.txt')->hash;
    is($grants->get_owner("Marcel")->hash->[0], $new_hash , "check updated owner hash 2");
    isnt($new_hash, $old_hash, "check that marcel.txt hash was changed");

    # check that marcel2.txt has email info
    is($grants->get_grant('marcel2.txt')->copyright->statement('Marcel')->email,'marcel@example.com',"check marcel2 grant");

    # check that marcel2.txt email has propagated to marcel.txt even
    # though the latter was created befire marcel2
    is($grants->get_grant('marcel.txt')->copyright->statement('Marcel')->email,'marcel@example.com',"check marcel2 grant");

    check_hash_consistency($grants);
};

subtest "email propagation - hash updates" => sub {
    my $grants = get_grant();
    $grants->add ('marcel.txt', 'GPL-2', '2015, Marcel <marcel2015@example.com>');
    $grants->add ('marcel2.txt', 'GPL-2', '2015, Marcel <marcel2015@example.com>');
    $grants->add ('marcel3.txt', 'GPL-2', '2016, Marcel <marcel2016@example.com>');

    # check that older email is updated
    is($grants->get_grant('marcel.txt')->copyright->statement('Marcel')->email,'marcel2016@example.com',"check marcel email");
    is($grants->get_grant('marcel2.txt')->copyright->statement('Marcel')->email,'marcel2016@example.com',"check marcel2 email");
    check_hash_consistency($grants);
};

subtest "merge after email propagation" => sub {
    my $grants = get_grant();

    $grants->add ('marcel.txt', 'GPL-2', '2015, Marcel');
    my $old_marcel_hash = $grants->get_grant('marcel.txt')->hash;

    $grants->add ('marcel2.txt', 'GPL-2', '2015, Marcel <marcel@example.com>');

    my $marcel_hash = $grants->get_grant('marcel.txt')->hash;
    my $marcel2_hash = $grants->get_grant('marcel2.txt')->hash;

    isnt($old_marcel_hash, $marcel_hash,"Since marcel grant was updated by merging an email, its new hash is different");

    is($marcel_hash, $marcel2_hash, "both grants have the same hash after merging email");

    # check that hash to file attribute point to both files
    is_deeply($grants->get_hash_files($marcel_hash),[qw/marcel.txt marcel2.txt/],"hash list was updated");
    isnt(defined $grants->get_hash_files($old_marcel_hash),"hash list was cleaned up");

    check_hash_consistency($grants);
};

subtest "merge after email propagation" => sub {
    my $grants = get_grant();

    $grants->add('merged.txt', 'GPL-2', "2012, Marcel\n2014 Marcel <marcel\@example.com>");
    is($grants->get_grant('merged.txt')->copyright->statement('Marcel').'','2012, 2014, Marcel <marcel@example.com>',"check grant");

    check_hash_consistency($grants);
};

subtest "merge after email propagation (reverse order)" => sub {
    my $grants = get_grant();

    $grants->add('merged.txt', 'GPL-2', "2014 Marcel <marcel\@example.com>\n2012, Marcel");
    is($grants->get_grant('merged.txt')->copyright->statement('Marcel').'','2012, 2014, Marcel <marcel@example.com>',"check marcel2 grant");

    check_hash_consistency($grants);
};

subtest "merge accross grants with different emails. different years" => sub {
    my $grants = get_grant();

    $grants->add('merged0.txt', 'GPL-2', "2010, Marcel");

    note("merging merged1.txt" );
    $grants->add('merged1.txt', 'GPL-2', "2014 Marcel <marcel1\@example.com>");
    is($grants->get_grant('merged0.txt')->copyright->statement('Marcel').'','2010, Marcel <marcel1@example.com>',"check merged0 email grant");

    note("merging merged2.txt" );
    $grants->add('merged2.txt', 'GPL-2', "2015, Marcel <marcel2\@example.com>");

    note("merging merged3.txt" );
    $grants->add('merged3.txt', 'GPL-2', "2012, Marcel");

    is($grants->get_grant('merged0.txt')->copyright->statement('Marcel').'','2010, Marcel <marcel2@example.com>',"check merged0 email grant (more recent email)");
    is($grants->get_grant('merged2.txt')->copyright->statement('Marcel').'','2015, Marcel <marcel2@example.com>',"check merged2 email grant");

    note("merging merged4.txt" );
    $grants->add('merged4.txt', 'GPL-2', "2011, Marcel <marcel-older\@example.com>");
    note("merging merged5.txt" );
    $grants->add('merged5.txt', 'GPL-2', "2012, Marcel");

    is($grants->get_grant('merged0.txt')->copyright->statement('Marcel').'','2010, Marcel <marcel2@example.com>',"check merged0 email grant (more recent email not clobbered)");
    is($grants->get_grant('merged5.txt')->copyright->statement('Marcel').'','2012, Marcel <marcel2@example.com>',"check merged5 email grant (updated with more recent email, year wise)");

    check_hash_consistency($grants);
};

subtest "all records have email" => sub {
    my $grants = get_grant();
    $grants->add('dummy01.txt', 'ISC', '2007-2015, Daniel Adler <dadler@uni-goettingen.de>');
    # call updated owner when there's no owner without email
    $grants->add('dummy02.txt', 'ISC', '2013, Daniel Adler <dadler@uni-goettingen.de>');
    ok(1, "correctly processed");
};

subtest "raku style merge" => sub {
    my $grants = get_grant();
    $grants->add('LICENSE', 'Artistic-2.0', '2015, Jonathan Stowe');
    $grants->add('README.md', 'UNKNOWN', '2015-2021, Jonathan Stowe');
    $grants->add('META6.json', 'Artistic-2.0', 'Jonathan Stowe <jns+git@gellyfish.co.uk>');

    check_hash_consistency($grants, "first");
    $grants->_copy_license_in_readme_info();
    check_hash_consistency($grants, "after copy license");
    is_deeply([sort $grants->files_without_info], [], "check files without info");
};

subtest "no info handling" => sub {
    my $grants = get_grant();
    $grants->add('LICENSE', 'Artistic-2.0', '2015, Jonathan Stowe');
    $grants->add('README.md', 'UNKNOWN', 'no-info-found');
    $grants->add('WRITEME.md', 'UNKNOWN', 'no-info-found');

    is_deeply([sort $grants->files], [qw/LICENSE README.md WRITEME.md/], "check files");
    is_deeply([sort $grants->files_without_info], [qw/README.md WRITEME.md/], "check files without info");
};

subtest "invalid copyright handling" => sub {
    my $grants = get_grant();
    $grants->add('LICENSE', 'Artistic-2.0', '2015');
    $grants->add('README.md', 'Artistic-2.0', '2020, Jonathan Stowe');
    $grants->add('WRITEME.md', 'Artistic-2.0', '2020');
    # guess what was before **b
    $grants->add('bn_mp_n_root.c', 'UNKNOWN', '**b <= a and (c+1)**b > a');

    is_deeply([sort $grants->files], [qw/LICENSE README.md WRITEME.md bn_mp_n_root.c/], "check files");

    is($grants->get_grant('LICENSE').'','Artistic-2.0',"copyright year of Artistic license was removed");
    is($grants->get_grant('WRITEME.md').'','Artistic-2.0 / 2020',"copyright year of file was kept even if unvalid");
};

subtest "fill blank data" => sub {
    my $grants = get_grant(
        fill_blank_data => {
            'foo.c' => {
                copyright => "2015 Marcel Mézigue"
            },
            'bar.c' => {
                'override-copyright' => "2015 Marcel Mézigue"
            },
            'foo.l' => {
                license => "Apache-2.0"
            },
            'bar.l' => {
                'override-license' => "Apache-2.0"
            },
        }
    );

    $grants->add('foo.c', 'Artistic-2.0', '');
    is($grants->get_grant('foo.c').'','Artistic-2.0 / 2015, Marcel Mézigue',"apply copyright");

    # Since the copyright entry is overridden above, we should not get a warning there
    $grants->add('bar.c', 'Artistic-2.0', '2014-2013, wrong guy, invalid range');
    is($grants->get_grant('bar.c').'','Artistic-2.0 / 2015, Marcel Mézigue',"override copyright");

    $grants->add('foo.l', '', '2015 Marcel Mézigue');
    is($grants->get_grant('foo.l').'','Apache-2.0 / 2015, Marcel Mézigue',"apply copyright");

    $grants->add('bar.l', 'WRONG_LICENSE', '2015 Marcel Mézigue');
    is($grants->get_grant('bar.l').'','Apache-2.0 / 2015, Marcel Mézigue',"ovveride copyright");
};

subtest "copy license info in readme file" => sub {
    my $grants = get_grant();
    $grants->add('LICENSE', 'Artistic-2.0', '2015, Jonathan Stowe');
    $grants->add('README.md', 'UNKNOWN', '2016 Joe Writer');

    $grants->_copy_license_in_readme_info;

    is($grants->get_grant('README.md').'','Artistic-2.0 / 2016, Joe Writer',"updated license in readme");

    my $hash = $grants->get_grant('README.md')->hash;
    my $found = grep { $_ eq 'README.md'} $grants->get_hash_files($hash)->@*;
    ok($found, "hash data was updated");
};

subtest "delete grants" => sub {
    my $grants = get_grant();
    my $goner = 'foo.txt';

    $grants->add ('marcel.txt', 'GPL-2', '2012, Marcel <marcel@example.com>');
    $grants->add ('marcel2.txt', 'GPL-2', '2015, Marcel <marcel@example.com>');
    $grants->add ($goner, 'GPL-2', '2015, Foo <foo@example.com>');

    $grants->delete_grant($goner);
    is($grants->get_grant($goner), undef, "$goner was deleted");

    check_hash_consistency($grants);
};

subtest "stop comment and license propagation" => sub {
    my $grants = get_grant();

    $grants->add ('marcel.txt', 'GPL-2', '2012, Marcel <marcel@example.com>');
    $grants->add ('marcel2.txt', 'GPL-2', '2012, Marcel <marcel@example.com>');
    my $hash = $grants->get_grant('marcel2.txt')->hash;

    is( $grants->get_grant('marcel.txt')->hash, $hash, "same hash");

    $grants->add_grant_info(file => 'marcel.txt', comment => "blah");
    is($grants->get_grant('marcel.txt')->comment(), 'blah', 'check comment');
    isnt( $grants->get_grant('marcel.txt')->hash, $hash, "different hash");
    is($grants->get_grant('marcel2.txt')->comment, '', "comment is not shared");

    $grants->add_grant_info(file => 'marcel.txt', license_text => "license blah blah");
    is($grants->get_grant('marcel.txt')->license_text, 'license blah blah', 'check license text');

    $grants->add_grant_info(
        file => 'marcel2.txt',
        comment => "blah",
        license_text => "license blah blah"
    );

    is( $grants->get_grant('marcel.txt')->hash,
        $grants->get_grant('marcel2.txt')->hash , "back to same hash");
};

subtest "merge_old_grants" => sub {
    # emulate data retrieved from debian/copyright
    my $old_grants = get_grant();

    $old_grants->add ('marcel.txt', 'GPL-2', '2012, Marcel');
    $old_grants->add ('marcel2.txt', 'GPL-2', '2012, Marcel');
    $old_grants->add ('marcel3.txt', 'GPL-2', '2015, Marcel <marcel@example.com>');
    $old_grants->add ('foo/marcel.txt', 'GPL-2', '2015, Marcel Foo <marcel.foo@example.com>');

    $old_grants->add_grant_info(file => 'marcel.txt', comment => 'marcel comment');
    $old_grants->add_grant_info(file => 'marcel.txt', license_text => 'marcel license');

    ok(1,"setup debian/copyright data emulation");

    # emulate new data retrieved from new software version
    my $new_grants = get_grant();

    # no change
    $new_grants->add ('marcel.txt', 'GPL-2', '2012, Marcel');
    $new_grants->add ('marcel2.txt', 'GPL-2', '2012, Marcel');
    # year update
    $new_grants->add ('marcel3.txt', 'GPL-2', '2015-2016, Marcel <marcel@example.com>');
    # file is moved
    $new_grants->add ('bar/marcel.txt', 'GPL-2', '2015, Marcel Foo <marcel.foo@example.com>');

    $new_grants->merge_old_grants($old_grants);

    is($new_grants->get_grant('marcel.txt')->comment(), 'marcel comment', 'check comment override');
    is($new_grants->get_grant('marcel.txt')->license_text(), 'marcel license', 'check license override');
    is($new_grants->get_grant('marcel.txt').'', 'GPL-2 / 2012, Marcel <marcel@example.com>', 'check unchanged file grant');

    is($new_grants->get_grant('marcel2.txt')->comment(), '', 'check no comment leak');

    is($new_grants->get_grant('foo/marcel.txt'), undef, 'check obsolete file');
    is($new_grants->get_grant('bar/marcel.txt').'', 'GPL-2 / 2015, Marcel Foo <marcel.foo@example.com>', "check new file");

    is($new_grants->get_grant('marcel3.txt').'', 'GPL-2 / 2015, 2016, Marcel <marcel@example.com>',"check updated copyright");
};

# TODO: test other method wichc tweaked no-info-found

done_testing;