← Back to branch summary

~bzr-pqm/bzr/bzr.dev

« back to all changes in this revision

Viewing changes to contrib/pwclient.full

(vila) Fix bzrlib.tests.test_gpg.TestVerify.test_verify_revoked_signature
 with recent versions of gpg. (Vincent Ladeuil)

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/pwclient.full
1
 
#!/usr/bin/perl -w
2
 
#
3
 
# Patchwork - automated patch tracking system
4
 
# Copyright (C) 2005 Jeremy Kerr <jk@ozlabs.org>
5
 
#
6
 
# This file is part of the Patchwork package.
7
 
#
8
 
# Patchwork is free software; you can redistribute it and/or modify
9
 
# it under the terms of the GNU General Public License as published by
10
 
# the Free Software Foundation; either version 2 of the License, or
11
 
# (at your option) any later version.
12
 
#
13
 
# Patchwork is distributed in the hope that it will be useful,
14
 
# but WITHOUT ANY WARRANTY; without even the implied warranty of
15
 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
 
# GNU General Public License for more details.
17
 
#
18
 
# You should have received a copy of the GNU General Public License
19
 
# along with Patchwork; if not, write to the Free Software
20
 
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21
 
 
22
 
use strict;
23
 
use lib '../lib';
24
 
 
25
 
use SOAP::Lite;
26
 
use Getopt::Std;
27
 
 
28
 
my $uri = 'urn:SOAPInterface';
29
 
# this URI has the address of the soap.pl script, followed by the project name
30
 
my $proxy = 'http://patchwork.ozlabs.org/soap.pl/bazaar-ng';
31
 
my $soap;
32
 
my ($rows, $cols);
33
 
 
34
 
my %actions = (
35
 
        list   => 'List all patches (restrict to a state with -s <state>)',
36
 
        view   => 'View a patch',
37
 
        get    => 'Download a patch and save it locally',
38
 
        apply  => 'Apply a patch (in the current dir, using -p1)',
39
 
        search => 'Search for patches (by name)'
40
 
);
41
 
 
42
 
sub page($@)
43
 
{
44
 
        my $str = shift;
45
 
        my $lines;
46
 
        if (@_) {
47
 
                ($lines) = @_;
48
 
        } else {
49
 
                my @l = split(/\n/, $str);
50
 
                $lines = $#l;
51
 
        }
52
 
        if ($rows && $lines >= $rows) {
53
 
                my $pager = $ENV{PAGER} || 'more';
54
 
                open(FH, "|-", $pager) || die "Couldn't run pager '$pager': $!";
55
 
                print FH $str;
56
 
                close(FH);
57
 
        } else {
58
 
                print $str;
59
 
        }
60
 
}
61
 
 
62
 
sub patch_list(@)
63
 
{
64
 
        my @patches = @_;
65
 
        my $states = 
66
 
        return "No patches\n" unless @patches;
67
 
        my $str = list_header();
68
 
        my $max = $cols - 9;
69
 
        $max = 10 if $max < 10;
70
 
        foreach my $patch (@patches) {
71
 
                my $name = $patch->name();
72
 
                if ($cols && length($name) > $max) {
73
 
                        $name = substr($name, 0, $max - 1).'$';
74
 
                }
75
 
                $str .= sprintf "%4d %3s %s\n", $patch->id(),
76
 
                                substr(states($patch->state()), 0, 3),
77
 
                                $name;
78
 
        }
79
 
        return $str;
80
 
}
81
 
 
82
 
sub _get_patch($)
83
 
{
84
 
        my ($id) = @_;
85
 
        unless ($id) {
86
 
                print STDERR "No id given to retrieve a patch\n";
87
 
                exit 1;
88
 
        }
89
 
 
90
 
        unless ($id =~ m/^[0-9]+$/) {
91
 
                print STDERR "Invalid patch id '$id'\n'";
92
 
                exit 1;
93
 
        }
94
 
 
95
 
        my $res = $soap->get_patch($id);
96
 
        die "SOAP fault: ".$res->faultstring if $res->fault;
97
 
        my $patch = $res->result;
98
 
        unless ($patch) {
99
 
                print STDERR "Patch not found\n";
100
 
                exit 1;
101
 
        }
102
 
        return $patch;
103
 
}
104
 
 
105
 
sub list()
106
 
{
107
 
        my %opts;
108
 
        my $res;
109
 
        getopts('s:', \%opts);
110
 
        if ($opts{s}) {
111
 
                $res = $soap->get_patches_by_state(state_from_name($opts{s}));
112
 
        } else {
113
 
                $res = $soap->get_patches();
114
 
        }
115
 
        die "SOAP fault: ".$res->faultstring if $res->fault;
116
 
        my $patches = $res->result;
117
 
        page(patch_list(@$patches), $#{$patches} + 2);
118
 
        return 1;
119
 
}
120
 
 
121
 
sub search()
122
 
{
123
 
        my $query = join(' ', map { '"'.$_.'"' } @ARGV);
124
 
        my $res = $soap->search($query);
125
 
        die "SOAP fault: ".$res->faultstring if $res->fault;
126
 
        my $patches = $res->result;
127
 
        my $str = '';
128
 
        unless ($patches && @{$patches}) {
129
 
                print "No patches found\n";
130
 
                return 1;
131
 
        }
132
 
        
133
 
        $str .= list_header();
134
 
        page(patch_list(@$patches), $#{$patches});
135
 
        return 1;
136
 
}
137
 
 
138
 
sub view()
139
 
{
140
 
        my ($id) = @ARGV;
141
 
        my $patch = _get_patch($id);
142
 
        page($patch->content());
143
 
        return 1;
144
 
}
145
 
 
146
 
sub get()
147
 
{
148
 
        my ($id) = @ARGV;
149
 
        my $patch = _get_patch($id);
150
 
        if (-e $patch->filename()) {
151
 
                printf STDERR "Patch file:\n\t%s\nalready exists\n",
152
 
                        $patch->filename();
153
 
                exit 1;
154
 
        }
155
 
        open(FH, ">", $patch->filename())
156
 
                or die "Couldn't open ".$patch->filename()." for writing: $!";
157
 
        print FH $patch->content;
158
 
        close(FH);
159
 
        printf "Saved '%s'\n\tto: %s\n", $patch->name, $patch->filename();
160
 
        return 1;
161
 
}
162
 
 
163
 
sub apply()
164
 
{
165
 
        my ($id) = @ARGV;
166
 
        my $patch = _get_patch($id);
167
 
        open(FH, "|-", "patch", "-p1")
168
 
                or die "Couldn't execute 'patch -p1'";
169
 
        print FH $patch->content;
170
 
        close(FH);
171
 
        return 1;
172
 
}
173
 
 
174
 
sub usage()
175
 
{
176
 
        printf STDERR "Usage: %s <action> [options]\n", $0;
177
 
        printf STDERR "Where <action> is one of:\n";
178
 
        printf STDERR "\t%-6s : %s\n", $_, $actions{$_} for sort keys %actions;
179
 
}
180
 
 
181
 
sub list_header()
182
 
{
183
 
        return sprintf "%4s %3s %s\n", 'ID', 'Sta', 'Name';
184
 
}
185
 
 
186
 
my %_states;
187
 
sub states(@)
188
 
{
189
 
        my $state = @_ ? shift : undef;
190
 
        unless (%_states) {
191
 
                my $res = $soap->get_states();
192
 
                die "SOAP fault: ".$res->faultstring if $res->fault;
193
 
                my $stateref = $res->result;
194
 
                %_states = %$stateref;
195
 
        }
196
 
        return $state ? $_states{$state} : %_states;
197
 
}
198
 
 
199
 
sub state_from_name($)
200
 
{
201
 
        my ($name) = @_;
202
 
        my @matches;
203
 
        my %states = states();
204
 
        foreach my $id (keys(%states)) {
205
 
                push(@matches, $id) if ($states{$id} =~ m/^$name/i);
206
 
        }
207
 
        if ($#matches < 0) {
208
 
                print STDERR "No such state '$name'\n";
209
 
                exit 1;
210
 
        } elsif ($#matches > 0) {
211
 
                printf STDERR "Multiple states match '$name':\n";
212
 
                printf STDERR "\t%s\n", $states{$_} for @matches;
213
 
                exit 1;
214
 
        }
215
 
        return $matches[0];
216
 
}
217
 
 
218
 
my $action = shift;
219
 
unless ($action) {
220
 
        usage();
221
 
        exit 1;
222
 
}
223
 
 
224
 
if (eval "require Term::Size") {
225
 
        ($cols, $rows) = Term::Size::chars(*STDOUT);
226
 
} else {
227
 
        ($cols, $rows) = (0,0);
228
 
}
229
 
 
230
 
$soap = new SOAP::Lite(uri => $uri, proxy => $proxy);
231
 
 
232
 
foreach (sort(keys(%actions))) {
233
 
        if ($_ eq $action) {
234
 
                eval "return &$action()" or die $@;
235
 
                exit 0;
236
 
        }
237
 
}
238
 
printf STDERR "No such action '%s'\n", $action;
239
 
usage();
240
 
exit 1;
241
 
 
242
 
# Patchwork - automated patch tracking system
243
 
# Copyright (C) 2005 Jeremy Kerr <jk@ozlabs.org>
244
 
#
245
 
# This file is part of the Patchwork package.
246
 
#
247
 
# Patchwork is free software; you can redistribute it and/or modify
248
 
# it under the terms of the GNU General Public License as published by
249
 
# the Free Software Foundation; either version 2 of the License, or
250
 
# (at your option) any later version.
251
 
#
252
 
# Patchwork is distributed in the hope that it will be useful,
253
 
# but WITHOUT ANY WARRANTY; without even the implied warranty of
254
 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
255
 
# GNU General Public License for more details.
256
 
#
257
 
# You should have received a copy of the GNU General Public License
258
 
# along with Patchwork; if not, write to the Free Software
259
 
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
260
 
 
261
 
package PatchWork::Comment;
262
 
 
263
 
use strict;
264
 
 
265
 
# internal variables
266
 
#  id
267
 
#  msgid
268
 
#  submitter
269
 
#  content
270
 
#  date
271
 
#  @refs
272
 
 
273
 
sub new($)
274
 
{
275
 
        my ($cls) = @_;
276
 
        my $obj = {};
277
 
        bless($obj, $cls);
278
 
        return $obj;
279
 
}
280
 
 
281
 
sub id(@)
282
 
{
283
 
        my ($obj) = shift;
284
 
        if (@_) { $obj->{id} = shift }
285
 
        return $obj->{id};
286
 
}
287
 
 
288
 
sub submitter(@)
289
 
{
290
 
        my ($obj) = shift;
291
 
        if (@_) { $obj->{submitter} = shift }
292
 
        return $obj->{submitter};
293
 
}
294
 
 
295
 
sub msgid(@)
296
 
{
297
 
        my ($obj) = shift;
298
 
        if (@_) { $obj->{msgid} = shift }
299
 
        return $obj->{msgid};
300
 
}
301
 
 
302
 
sub date(@)
303
 
{
304
 
        my ($obj) = shift;
305
 
        if (@_) { $obj->{date} = shift }
306
 
        return $obj->{date};
307
 
}
308
 
 
309
 
sub content(@)
310
 
{
311
 
        my ($obj) = shift;
312
 
        if (@_) { $obj->{content} = shift }
313
 
        return $obj->{content};
314
 
}
315
 
 
316
 
sub refs(@)
317
 
{
318
 
        my ($obj) = shift;
319
 
        push(@{$obj->{refs}}, @_) if @_;
320
 
        return $obj->{refs};
321
 
}
322
 
 
323
 
1;
324
 
 
325
 
# Patchwork - automated patch tracking system
326
 
# Copyright (C) 2005 Jeremy Kerr <jk@ozlabs.org>
327
 
#
328
 
# This file is part of the Patchwork package.
329
 
#
330
 
# Patchwork is free software; you can redistribute it and/or modify
331
 
# it under the terms of the GNU General Public License as published by
332
 
# the Free Software Foundation; either version 2 of the License, or
333
 
# (at your option) any later version.
334
 
#
335
 
# Patchwork is distributed in the hope that it will be useful,
336
 
# but WITHOUT ANY WARRANTY; without even the implied warranty of
337
 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
338
 
# GNU General Public License for more details.
339
 
#
340
 
# You should have received a copy of the GNU General Public License
341
 
# along with Patchwork; if not, write to the Free Software
342
 
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
343
 
 
344
 
package PatchWork::Person;
345
 
 
346
 
use strict;
347
 
 
348
 
# internal variables
349
 
#   email
350
 
#   name
351
 
 
352
 
sub new(@)
353
 
{
354
 
        my $cls = shift;
355
 
        my $obj = {};
356
 
        bless($obj, $cls);
357
 
        $obj->{email} = shift;
358
 
        $obj->{name} = shift;
359
 
        return $obj;
360
 
}
361
 
 
362
 
sub parse_from($$)
363
 
{
364
 
        my ($obj, $str) = @_;
365
 
 
366
 
        if ($str =~ m/"?(.*?)"?\s*<([^>]+)>/) {
367
 
                $obj->{email} = $2;
368
 
                $obj->{name} = $1;
369
 
        
370
 
        } elsif ($str =~ m/"?(.*?)"?\s*\(([^\)]+)\)/) {
371
 
                $obj->{email} = $1;
372
 
                $obj->{name} = $2;
373
 
        
374
 
        } else {
375
 
                $obj->{email} = $str;
376
 
        }
377
 
}
378
 
 
379
 
sub id(@)
380
 
{
381
 
        my ($obj) = shift;
382
 
        if (@_) { $obj->{id} = shift }
383
 
        return $obj->{id};
384
 
}
385
 
 
386
 
sub email(@)
387
 
{
388
 
        my ($obj) = shift;
389
 
        if (@_) { $obj->{email} = shift }
390
 
        return $obj->{email};
391
 
}
392
 
 
393
 
sub name(@)
394
 
{
395
 
        my ($obj) = shift;
396
 
        if (@_) { $obj->{name} = shift }
397
 
        return $obj->{name};
398
 
}
399
 
 
400
 
sub username(@)
401
 
{
402
 
        my ($obj) = shift;
403
 
        if (@_) { $obj->{username} = shift }
404
 
        return $obj->{username};
405
 
}
406
 
 
407
 
1;
408
 
 
409
 
# Patchwork - automated patch tracking system
410
 
# Copyright (C) 2005 Jeremy Kerr <jk@ozlabs.org>
411
 
#
412
 
# This file is part of the Patchwork package.
413
 
#
414
 
# Patchwork is free software; you can redistribute it and/or modify
415
 
# it under the terms of the GNU General Public License as published by
416
 
# the Free Software Foundation; either version 2 of the License, or
417
 
# (at your option) any later version.
418
 
#
419
 
# Patchwork is distributed in the hope that it will be useful,
420
 
# but WITHOUT ANY WARRANTY; without even the implied warranty of
421
 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
422
 
# GNU General Public License for more details.
423
 
#
424
 
# You should have received a copy of the GNU General Public License
425
 
# along with Patchwork; if not, write to the Free Software
426
 
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
427
 
 
428
 
package PatchWork::Patch;
429
 
 
430
 
use strict;
431
 
 
432
 
# internal variables
433
 
#  id
434
 
#  msgid
435
 
#  date
436
 
#  name
437
 
#  content
438
 
#  filename
439
 
#  submitter
440
 
#  comments
441
 
#  @trees
442
 
 
443
 
sub new($)
444
 
{
445
 
        my ($cls) = @_;
446
 
        my $obj = {};
447
 
        bless($obj, $cls);
448
 
        $obj->{comments} = [];
449
 
        $obj->{trees} = {};
450
 
        $obj->{archived} = 0;
451
 
        $obj->{state} = 1;
452
 
        return $obj;
453
 
}
454
 
 
455
 
sub id(@)
456
 
{
457
 
        my ($obj) = shift;
458
 
        if (@_) { $obj->{id} = shift }
459
 
        return $obj->{id};
460
 
}
461
 
 
462
 
sub msgid(@)
463
 
{
464
 
        my ($obj) = shift;
465
 
        if (@_) { $obj->{msgid} = shift }
466
 
        return $obj->{msgid};
467
 
}
468
 
 
469
 
sub date(@)
470
 
{
471
 
        my ($obj) = shift;
472
 
        if (@_) { $obj->{date} = shift }
473
 
        return $obj->{date};
474
 
}
475
 
 
476
 
sub state(@)
477
 
{
478
 
        my ($obj) = shift;
479
 
        if (@_) { $obj->{state} = shift }
480
 
        return $obj->{state};
481
 
}
482
 
 
483
 
sub name(@)
484
 
{
485
 
        my ($obj) = shift;
486
 
        if (@_) { $obj->{name} = shift }
487
 
        return $obj->{name};
488
 
}
489
 
 
490
 
sub filename(@)
491
 
{
492
 
        my ($obj) = shift;
493
 
        if (@_) { $obj->{filename} = shift }
494
 
        return $obj->{filename};
495
 
}
496
 
 
497
 
sub submitter(@)
498
 
{
499
 
        my ($obj) = shift;
500
 
        if (@_) { $obj->{submitter} = shift }
501
 
        return $obj->{submitter};
502
 
}
503
 
 
504
 
sub content(@)
505
 
{
506
 
        my ($obj) = shift;
507
 
        if (@_) { $obj->{content} = shift }
508
 
        return $obj->{content};
509
 
}
510
 
 
511
 
sub archived(@)
512
 
{
513
 
        my ($obj) = shift;
514
 
        if (@_) { $obj->{archived} = shift }
515
 
        return $obj->{archived};
516
 
}
517
 
 
518
 
sub add_comment($$)
519
 
{
520
 
        my ($obj, $comment) = @_;
521
 
        push(@{$obj->{comments}}, $comment);
522
 
}
523
 
 
524
 
sub comments($)
525
 
{
526
 
        my ($obj) = @_;
527
 
        return $obj->{comments};
528
 
}
529
 
 
530
 
sub trees(@)
531
 
{
532
 
        my ($obj) = shift;
533
 
        if (@_) { $obj->{trees} = shift }
534
 
        return $obj->{trees};
535
 
}
536
 
 
537
 
1;
538
 
 
539
 
# Patchwork - automated patch tracking system
540
 
# Copyright (C) 2005 Jeremy Kerr <jk@ozlabs.org>
541
 
#
542
 
# This file is part of the Patchwork package.
543
 
#
544
 
# Patchwork is free software; you can redistribute it and/or modify
545
 
# it under the terms of the GNU General Public License as published by
546
 
# the Free Software Foundation; either version 2 of the License, or
547
 
# (at your option) any later version.
548
 
#
549
 
# Patchwork is distributed in the hope that it will be useful,
550
 
# but WITHOUT ANY WARRANTY; without even the implied warranty of
551
 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
552
 
# GNU General Public License for more details.
553
 
#
554
 
# You should have received a copy of the GNU General Public License
555
 
# along with Patchwork; if not, write to the Free Software
556
 
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
557
 
 
558
 
package PatchWork::Tree;
559
 
 
560
 
use strict;
561
 
 
562
 
# internal variables
563
 
#   id
564
 
#   name
565
 
#   url
566
 
 
567
 
sub new($$)
568
 
{
569
 
        my ($cls, $id) = @_;
570
 
        my $obj = {};
571
 
        bless($obj, $cls);
572
 
        $obj->{id} = $id;
573
 
        return $obj;
574
 
}
575
 
 
576
 
sub id($)
577
 
{
578
 
        my ($obj) = @_;
579
 
        return $obj->{id};
580
 
 
581
 
}
582
 
 
583
 
sub name(@)
584
 
{
585
 
        my ($obj) = shift;
586
 
        if (@_) { $obj->{name} = shift }
587
 
        return $obj->{name};
588
 
}
589
 
 
590
 
sub url(@)
591
 
{
592
 
        my ($obj) = shift;
593
 
        if (@_) { $obj->{url} = shift }
594
 
        return $obj->{url};
595
 
}
596
 
 
597
 
1;
598
 
 
599
 
# Patchwork - automated patch tracking system
600
 
# Copyright (C) 2005 Jeremy Kerr <jk@ozlabs.org>
601
 
#
602
 
# This file is part of the Patchwork package.
603
 
#
604
 
# Patchwork is free software; you can redistribute it and/or modify
605
 
# it under the terms of the GNU General Public License as published by
606
 
# the Free Software Foundation; either version 2 of the License, or
607
 
# (at your option) any later version.
608
 
#
609
 
# Patchwork is distributed in the hope that it will be useful,
610
 
# but WITHOUT ANY WARRANTY; without even the implied warranty of
611
 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
612
 
# GNU General Public License for more details.
613
 
#
614
 
# You should have received a copy of the GNU General Public License
615
 
# along with Patchwork; if not, write to the Free Software
616
 
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
617
 
 
618
 
package PatchWork::User;
619
 
@PatchWork::User::ISA = ('PatchWork::Person');
620
 
 
621
 
use strict;
622
 
 
623
 
# internal variables
624
 
#   username
625
 
 
626
 
sub new($$)
627
 
{
628
 
        my ($cls, $id) = @_;
629
 
        my $obj = {};
630
 
        bless($obj, $cls);
631
 
        $obj->{id} = $id;
632
 
        return $obj;
633
 
}
634
 
 
635
 
sub username(@)
636
 
{
637
 
        my ($obj) = shift;
638
 
        if (@_) { $obj->{username} = shift }
639
 
        return $obj->{username};
640
 
}
641
 
 
642
 
1;
643