source: server/trunk/web/lib/Sophie/Controller/Chat/Cmd.pm @ 388

Last change on this file since 388 was 388, checked in by nanardon, 13 years ago
  • return an error on unknown options
  • Property svn:keywords set to Id Rev
File size: 31.0 KB
Line 
1package Sophie::Controller::Chat::Cmd;
2use Moose;
3use namespace::autoclean;
4use Getopt::Long;
5
6BEGIN {extends 'Catalyst::Controller'; }
7
8=head1 NAME
9
10Sophie::Controller::Chat::Cmd - Catalyst Controller
11
12=head1 DESCRIPTION
13
14Catalyst Controller.
15
16=head1 METHODS
17
18=cut
19
20
21=head2 index
22
23=cut
24
25=head2 end
26
27=cut
28
29sub end : Private {
30    my ($self, $c ) = @_;
31   
32    $c->forward('/chat/update_statistic', [ ($c->action =~ /([^\/]+)$/)[0] ]);
33
34    my $reqspec = $c->req->arguments->[0];
35    $reqspec->{max_line} ||= 4;
36    my $message =  $c->stash->{xmlrpc};
37
38    my @backup = @{ $message->{message} };
39    my $needpaste = 0;
40
41    if (@{ $message->{message} } > ($reqspec->{max_line})) {
42        @{ $message->{message} } = 
43            # -2 because line 0 and we remove one for paste url
44            @backup[0 .. $reqspec->{max_line} -2];
45        $needpaste = 1;
46    } 
47
48    if ($needpaste && !$reqspec->{nopaste}) {
49        my $cmd = ($c->action =~ /([^\/]+)$/)[0];
50        my (undef, undef, @args) = @{ $c->req->arguments };
51        my $title = join(' ', $cmd, @args); 
52        my $id = $c->forward('/chat/paste', [ $title, join("\n", @backup) ]);
53        if ($id) {
54            push(@{ $message->{message} }, 'All results available here: ' . $c->uri_for('/chat', $id));
55        }
56    }
57
58    $c->stash->{xmlrpc} = $message;
59
60    $c->forward('/end');
61}
62
63=head1 BOT COMMAND
64
65=head2 REPLY
66
67=cut
68
69sub _commands {
70    my ( $self, $c ) = @_;
71    [ grep { m/^[^_]/ } map { $_->name } $self->get_action_methods() ];
72}
73
74sub _getopt : Private {
75    my ( $self, $c, $options, @args) = @_;
76
77    local @ARGV = @args;
78
79    eval {
80        # Getopt::Long don't return the error but use warn
81        local $SIG{__WARN__} = sub { 
82            my ($message) = @_;
83            chomp($message);
84            $c->stash->{xmlrpc} = {
85                message => [ $message ]
86            };
87        };
88
89        GetOptions(%{ $options || {} }) or do {
90            $c->stash->{getopt_error} = 1;
91        };
92    };
93    if ($@) {
94        $c->stash->{getopt_error} = 1;
95    }
96
97    return [ @ARGV ];
98}
99
100sub _fmt_location : Private {
101    my ($self, $c, $searchspec, $pkgid) = @_;
102
103    my @loc;
104    foreach (@{ $c->forward('/rpms/location', [ $pkgid ]) }) {
105        push @loc, sprintf(
106            '%s (%s, %s, %s)',
107            $_->{media},
108            $_->{dist} || $_->{distribution},
109            $_->{release},
110            $_->{arch},
111        );
112    }
113    return join(', ', @loc);
114}
115
116sub _fmt_question : Private {
117    my ($self, $c, $searchspec) = @_;
118
119    my $loc;
120    $loc = sprintf(
121        '(%s, %s, %s)',
122        $searchspec->{dist} || $searchspec->{distribution} || "*",
123        $searchspec->{release} || "*",
124        $searchspec->{arch} || "*",
125    );
126   
127    return $loc;
128}
129
130sub _find_rpm_elsewhere : Private {
131    my ($self, $c, $searchspec, $name) = @_;
132    if ($searchspec->{distribution}) {
133        my $rpmlist = $c->forward('/search/rpm/byname', [ 
134                {
135                    distribution => $searchspec->{distribution},
136                    src => $searchspec->{src},
137                    rows => 1,
138                }, $name ]);
139        if (@{$rpmlist}) {
140            return $c->forward('_fmt_location', [ { 
141                        distribution => $searchspec->{distribution}
142                    }, $rpmlist->[0] ]);
143        }
144    }
145    my $rpmlist = $c->forward('/search/rpm/byname', [ { src =>
146                $searchspec->{src}}, $name ]);
147    my %dist;
148    foreach(@$rpmlist) {
149        foreach (@{ $c->forward('/rpms/location', [ $_ ]) }) {
150            $dist{$_->{dist} || $_->{distribution}} = 1;
151        }
152    }
153    if (keys %dist) {
154        return join(', ', sort keys %dist);
155    }
156    return;
157}
158
159=head1 AVAILABLE FUNCTIONS
160
161=cut
162
163=head2 help [cmd]
164
165Return help about command cmd or list available command.
166
167=cut
168
169sub help : XMLRPC {
170    my ( $self, $c, $reqspec, $cmd ) = @_;
171    if ($cmd) {
172        my @message = grep { /\S+/ } split(/\n/,
173            $c->model('Help::POD')->bot_help_text($cmd) || 'No help available');
174        return $c->{stash}->{xmlrpc} = {
175            private_reply => 1,
176            message => \@message,
177        };
178    } else {
179        return $c->{stash}->{xmlrpc} = {
180            private_reply => 1,
181            message => [
182                'available command:',
183                join(', ', sort grep { $_ !~ /^end$/ } @{ $self->_commands }),
184                'Find more at ' . $c->uri_for('/help/chat'),
185            ],
186        }
187    }
188}
189
190=head2 set [distribution|release|arch] value
191
192Set default search value (see also: unset)
193
194=cut
195
196sub set : XMLRPC {
197    my ( $self, $c, $reqspec, $var, $val ) = @_;
198
199    if (!$var) {
200        return $c->stash->{xmlrpc} = {
201            private_reply => 1,
202            message => [
203                "What must I set ?"
204            ]
205        }
206    } 
207   
208    if (!$val) {
209        return $c->stash->{xmlrpc} = {
210            private_reply => 1,
211            message => [
212                "To what must I set $var ?"
213            ]
214        }
215    } 
216   
217    $c->forward('/user/update_data', [ $reqspec->{from}, { $var => $val } ]);
218
219    return $c->stash->{xmlrpc} = {
220        private_reply => 1,
221        message => [
222            "$var set to: " . ($val || '(none)'),
223            ($c->forward('/distrib/exists', [
224                    $c->forward('/user/fetchdata', [ $reqspec->{from}, ]) ])
225                ? ()
226                : ("warning: your setting does not match any distribution")
227            ),
228        ]
229    };
230}
231
232=head2 unset [distribution|release|arch]
233
234Unset default search value (see also: set)
235
236=cut
237
238sub unset : XMLRPC {
239    my ( $self, $c, $reqspec, $var ) = @_;
240
241
242    if (!$var) {
243        return $c->stash->{xmlrpc} = {
244            private_reply => 1,
245            message => [
246                "What must I unset ?"
247            ]
248        }
249    } 
250   
251    $c->forward('/user/update_data', [ $reqspec->{from}, { $var => undef } ]);
252   
253    return $c->stash->{xmlrpc} = {
254        private_reply => 1,
255        message => [ "$var set to: (none)" ],
256    };
257}
258
259=head2 show [var]
260
261Show your user settings
262
263=cut
264
265sub show : XMLRPC {
266    my ( $self, $c, $reqspec, $var, ) = @_;
267
268    my $res = $c->forward('/user/fetchdata', [ $reqspec->{from}, ]);
269   
270    if ($var) {
271        my $own = $res->{$var} || '(none)';
272        my $applied = $reqspec->{$var} || '(none)';
273        return $c->stash->{xmlrpc} = {
274            message => [ sprintf("%s is set to %s%s",
275                $var,
276                $own,
277                ($own ne $applied
278                    ? " ($applied is used in this context)"
279                    : '')
280            ) ]
281        };
282    } else {
283        my $own = $c->forward('_fmt_question', [$res]);
284        my $applied = $c->forward('_fmt_question', [$reqspec]);
285
286        return $c->stash->{xmlrpc} = {
287            message => [ sprintf('your setting is: %s%s',
288                $own,
289                ($own ne $applied
290                    ? " ($applied is used in this context)"
291                    : ''
292                )
293            ),
294            ($c->forward('/distrib/exists', [ $res ])
295                ? ()
296                : ("warning: your setting does not match any distribution")
297            )
298            ],
299        }
300    }
301}
302
303=head2 asv
304
305ASV means in french "age, sexe, ville" (age, sex and town).
306Return the version of the Chat module version.
307
308=cut
309
310sub asv : XMLRPC {
311    my ( $self, $c ) = @_;
312    return $c->stash->{xmlrpc} = {
313        message => [ 'Sophie: ' . $Sophie::VERSION . ', Chat ' . q$Rev$ ],
314    };
315}
316
317=head2 list [distribution [release [arch]]]
318
319List available distribution, release, architecture matching given arguments.
320
321=cut
322
323sub list : XMLRPC {
324    my ($self, $c, $reqspec, @args) = @_;
325
326    my $distrib = {
327        distribution => $args[0],
328        release      => $args[1],
329        arch         => $args[2],
330    };
331
332    if (!$c->forward('/distrib/exists', [ $distrib ])) {
333        return $c->stash->{xmlrpc} = {
334            message => [ "I don't have any distribution matching: "
335                         . join(' / ', grep { $_ } @args[0..2]) ],
336        };
337    }
338
339    my @list = @{ $c->forward('/distrib/list', [ $distrib ]) };
340    return $c->stash->{xmlrpc} = {
341        message => [ 
342            ($args[0] 
343                ? join(' / ', grep { $_ } @args[0..2]) . ': '
344                : '') .
345            join(', ', @list) ],
346    }
347}
348
349=head2 q [-d distrib] [-r release] [-a arch] [-s]  REGEXP
350
351Search rpm name matching C<REGEXP>.
352
353NB: C<.>, C<*>, C<+> have special meaning
354and have to be escaped.
355
356=cut
357
358sub q : XMLRPC {
359    my ($self, $c, $reqspec, @args) = @_;
360
361    $reqspec->{src} = 0;
362
363    @args = @{ $c->forward('_getopt', [
364        {
365            'd=s' => \$reqspec->{distribution},
366            'v=s' => \$reqspec->{release},
367            'r=s' => \$reqspec->{release},
368            'a=s' => \$reqspec->{arch},
369            's'   => sub { $reqspec->{src} = 1 },
370        }, @args ]) };
371
372    if ($c->stash->{getopt_error}) {
373        return $c->stash->{xmlrpc};
374    }
375
376    my $res = $c->forward('/search/tags/name_regexp', $reqspec, $args[0]);
377    if (!@{ $res }) {
378        return $c->stash->{xmlrpc} = {
379            message => [ "Nothing matches `$args[0]' in "
380                    .$c->forward('_fmt_question', [$reqspec])],
381        };
382    } else {
383        my @message = "rpm name matching `$args[0]' in "
384                    .$c->forward('_fmt_question', [$reqspec])." :";
385        while (@{ $res }) {
386            my $str = '';
387            while (length($str) < 70) {
388                my $item = shift(@{ $res }) or last;
389                $str .= ', ' if ($str);
390                $str .= $item->{name};
391            }
392            push(@message, $str);
393        }
394        return $c->stash->{xmlrpc} = {
395            message => \@message,
396        };
397    }
398}
399
400=head2 whatis [-d distrib] [-r release] [-a arch] [-s]  WORD [WORD2 [...]]
401
402Search rpm having description containing words given as arguments
403
404=cut
405
406sub whatis : XMLRPC {
407    my ($self, $c, $reqspec, @args) = @_;
408
409    $reqspec->{src} = 0;
410
411    @args = @{ $c->forward('_getopt', [
412        {
413            'd=s' => \$reqspec->{distribution},
414            'v=s' => \$reqspec->{release},
415            'r=s' => \$reqspec->{release},
416            'a=s' => \$reqspec->{arch},
417            's'   => sub { $reqspec->{src} = 1 },
418        }, @args ]) };
419    if ($c->stash->{getopt_error}) {
420        return $c->stash->{xmlrpc};
421    }
422
423    my $res = $c->forward('/search/rpm/description', [ $reqspec, @args ]);
424
425    if (@{ $res }) {
426        if (@{ $res } > 100) {
427            return $c->stash->{xmlrpc} = {
428                message => [ 'I have ' . @{ $res } . ' results in '
429                    .$c->forward('_fmt_question', [$reqspec])],
430            };
431        } else {
432            my @names = ();
433            foreach (@{ $res }) {
434                my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
435                push(@names, $info->{name});
436            }
437            my @message = "rpm name matching `$args[0]' in "
438                    .$c->forward('_fmt_question', [$reqspec])." :";
439            while (@names) {
440                my $str = '';
441                while (length($str) < 70) {
442                    my $item = shift(@names) or last;
443                    $str .= ', ' if ($str);
444                    $str .= $item;
445                }
446                push(@message, $str);
447            }
448            return $c->stash->{xmlrpc} = {
449                message => \@message,
450            };
451        }
452    } else {
453        return $c->stash->{xmlrpc} = {
454            message => [ 'No rpm description matches this keywords in '
455                    .$c->forward('_fmt_question', [$reqspec])],
456        };
457    }
458}
459
460=head2 version [-d distrib] [-r release] [-a arch] [-s] NAME
461
462Show the version of package C<NAME>.
463
464=cut
465
466sub version : XMLRPC {
467    my ($self, $c, $reqspec, @args) = @_;
468
469    my @message;
470    $reqspec->{src} = 0;
471
472    @args = @{ $c->forward('_getopt', [
473        {
474            'd=s' => \$reqspec->{distribution},
475            'v=s' => \$reqspec->{release},
476            'r=s' => \$reqspec->{release},
477            'a=s' => \$reqspec->{arch},
478            's'   => sub { $reqspec->{src} = 1 },
479        }, @args ]) };
480    if ($c->stash->{getopt_error}) {
481        return $c->stash->{xmlrpc};
482    }
483
484    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
485        return $c->stash->{xmlrpc} = {
486            message => [ "I don't have such distribution : " 
487                    .$c->forward('_fmt_question', [$reqspec])],
488        };
489    }
490
491    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
492    if (!@{ $rpmlist }) {
493        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
494        if ($else) {
495            return $c->stash->{xmlrpc} = {
496                message => [ 
497                    "There is no rpm named `$args[0]' in "
498                    .$c->forward('_fmt_question', [$reqspec])
499                    .", but the word matches in " . $else
500                ],
501            }
502        } else {
503            return $c->stash->{xmlrpc} = {
504                message => [ "The rpm named `$args[0]' has not been found in "
505                    .$c->forward('_fmt_question', [$reqspec])],
506            }
507        }
508    }
509    foreach (@{ $rpmlist }) {
510        my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
511        push @message, $info->{evr} . ' // ' .
512            $c->forward('_fmt_location', [ $reqspec, $_ ]);
513    }
514    return $c->stash->{xmlrpc} = {
515        message => [ @message ],
516    }
517}
518
519=head2 v
520
521C<v> is an alias for C<version> command.
522
523=cut
524
525sub v : XMLRPC {
526    my ($self, $c, @args) = @_;
527    $c->forward('version', [ @args ]);
528}
529
530=head2 summary [-d distrib] [-r release] [-a arch] [-s]  NAME
531
532Show the summary of package C<NAME>.
533
534=cut
535
536sub summary : XMLRPC {
537    my ($self, $c, $reqspec, @args) = @_;
538
539    $c->forward('qf', [ $reqspec, @args, '%{summary}' ]);
540}
541
542=head2 s
543
544Is an alias for C<summary> command.
545
546=cut
547
548sub s : XMLRPC {
549    my ($self, $c, @args) = @_;
550    $c->forward('summary', [ @args ]);
551}
552
553=head2 packager [-d distrib] [-r release] [-a arch] [-s]  NAME
554
555Show the packager of package C<NAME>.
556
557=cut
558
559sub packager : XMLRPC {
560    my ($self, $c, $reqspec, @args) = @_;
561
562    $c->forward('qf', [ $reqspec, @args, '%{packager}' ]);
563}
564
565=head2 p
566
567Is an alias for C<packager> command.
568
569=cut
570
571sub p : XMLRPC {
572    my ($self, $c, @args) = @_;
573    $c->forward('packager', [ @args ]);
574}
575
576=head2 arch [-d distrib] [-r release] [-a arch] [-s]  NAME
577
578Show the architecture of package C<NAME>.
579
580=cut 
581
582sub arch : XMLRPC {
583    my ($self, $c, $reqspec, @args) = @_;
584
585    $c->forward('qf', [ $reqspec, @args, '%{arch}' ]);
586}
587
588=head2 a
589
590Is an alias to C<arch> command.
591
592=cut 
593
594sub a : XMLRPC {
595    my ($self, $c, @args) = @_;
596    $c->forward('arch', [ @args ]);
597}
598
599=head2 url [-d distrib] [-r release] [-a arch] [-s]  NAME
600
601Show the url of package C<NAME>.
602
603=cut 
604
605sub url : XMLRPC {
606    my ($self, $c, $reqspec, @args) = @_;
607
608    $c->forward('qf', [ $reqspec, @args, '%{url}' ]);
609}
610
611=head2 u
612
613Is an alias to C<url> command.
614
615=cut 
616
617sub u : XMLRPC {
618    my ($self, $c, @args) = @_;
619    $c->forward('url', [ @args ]);
620}
621
622=head2 group [-d distrib] [-r release] [-a arch] [-s] NAME
623
624Show the group of package C<NAME>.
625
626=cut 
627
628sub group : XMLRPC {
629    my ($self, $c, $reqspec, @args) = @_;
630
631    $c->forward('qf', [ $reqspec, @args, '%{group}' ]);
632}
633
634=head2 g
635
636Is an alias to C<group> command.
637
638=cut 
639
640sub g : XMLRPC {
641    my ($self, $c, @args) = @_;
642    $c->forward('group', [ @args ]);
643}
644
645=head2 license [-d distrib] [-r release] [-a arch] [-s] NAME
646
647Show the license of package C<NAME>.
648
649=cut 
650
651sub license : XMLRPC {
652    my ($self, $c, $reqspec, @args) = @_;
653
654    $c->forward('qf', [ $reqspec, @args, '%{license}' ]);
655}
656
657=head2 l
658
659Is an alias to C<license> command.
660
661=cut 
662
663sub l : XMLRPC {
664    my ($self, $c, @args) = @_;
665    $c->forward('license', [ @args ]);
666}
667
668=head2 buildtime [-d distrib] [-r release] [-a arch] [-s] NAME
669
670Show the build time of package C<NAME>.
671
672=cut
673
674sub buildtime : XMLRPC {
675    my ($self, $c, $reqspec, @args) = @_;
676
677    $c->forward('qf', [ $reqspec, @args, '%{buildtime:date}' ]);
678}
679
680=head2 builddate
681
682Is an alias for C<buildtime> command.
683
684=cut
685
686sub builddate : XMLRPC {
687    my ($self, $c, @args) = @_;
688    $c->forward('buildtime', [ @args ]);
689}
690
691=head2 b
692
693Is an alias for C<buildtime> command.
694
695=cut
696
697sub b : XMLRPC {
698    my ($self, $c, @args) = @_;
699    $c->forward('builddate', [ @args ]);
700}
701
702=head2 cookie [-d distrib] [-r release] [-a arch] [-s]  NAME
703
704Show the C<cookie> tag of package C<NAME>.
705
706=cut
707
708sub cookie : XMLRPC {
709    my ($self, $c, $reqspec, @args) = @_;
710
711    $c->forward('qf', [ $reqspec, @args, '%{cookie}' ]);
712}
713
714=head2 sourcerpm [-d distrib] [-r release] [-a arch] [-s] NAME
715
716Show the C<sourcerpm> tag of package C<NAME>.
717
718=cut
719
720sub sourcerpm : XMLRPC {
721    my ($self, $c, $reqspec, @args) = @_;
722
723    $c->forward('qf', [ $reqspec, @args, '%{sourcerpm}' ]);
724}
725
726=head2 src NAME
727
728Is an alias for C<sourcerpm> command.
729
730=cut
731
732sub src : XMLRPC {
733    my ($self, $c, $reqspec, @args) = @_;
734
735    $c->forward('sourcerpm', [ $reqspec, @args ]);
736}
737
738=head2 rpmversion [-d distrib] [-r release] [-a arch] [-s] NAME
739
740Show the C<rpmversion> tag of package C<NAME>.
741
742=cut
743
744sub rpmversion : XMLRPC {
745    my ($self, $c, $reqspec, @args) = @_;
746
747    $c->forward('qf', [ $reqspec, @args, '%{rpmversion}' ]);
748}
749
750=head2 rpmbuildversion NAME
751
752Is an alias for C<rpmversion> command.
753
754=cut
755
756sub rpmbuildversion : XMLRPC {
757    my ($self, $c, $reqspec, @args) = @_;
758
759    $c->forward('rpmversion', [ $reqspec, @args ]);
760}
761
762
763=head2 buildhost [-d distrib] [-r release] [-a arch] [-s] NAME
764
765Show the C<buildhost> tag of package C<NAME>.
766
767=cut
768
769sub buildhost : XMLRPC {
770    my ($self, $c, $reqspec, @args) = @_;
771
772    $c->forward('qf', [ $reqspec, @args, '%{buildhost}' ]);
773}
774
775=head2 host NAME
776
777Is an alias for C<buildhost> command.
778
779=cut
780
781sub host : XMLRPC {
782    my ($self, $c, $reqspec, @args) = @_;
783
784    $c->forward('host', [ $reqspec, @args ]);
785}
786
787=head2 h NAME
788
789Is an alias for C<buildhost> command.
790
791=cut
792
793sub h : XMLRPC {
794    my ($self, $c, $reqspec, @args) = @_;
795
796    $c->forward('host', [ $reqspec, @args ]);
797}
798
799
800
801=head2 distribution [-d distrib] [-r release] [-a arch] [-s] NAME
802
803Show the C<distribution> tag of package C<NAME>.
804
805=cut
806
807sub distribution : XMLRPC {
808    my ($self, $c, $reqspec, @args) = @_;
809
810    $c->forward('qf', [ $reqspec, @args, '%{distribution}' ]);
811}
812
813=head2 distrib NAME
814
815Is an alias for C<distribution> command.
816
817=cut
818
819sub distrib : XMLRPC {
820    my ($self, $c, $reqspec, @args) = @_;
821
822    $c->forward('distribution', [ $reqspec, @args ]);
823}
824
825
826
827=head2 vendor [-d distrib] [-r release] [-a arch] [-s] NAME
828
829Show the C<vendor> tag of package C<NAME>.
830
831=cut
832
833sub vendor : XMLRPC {
834    my ($self, $c, $reqspec, @args) = @_;
835
836    $c->forward('qf', [ $reqspec, @args, '%{vendor}' ]);
837}
838
839=head2 qf [-d distrib] [-r release] [-a arch] [-s] NAME FMT
840
841Perform an rpm -q --qf C<FMT> on package C<NAME>.
842
843=cut
844
845sub qf : XMLRPC {
846    my ($self, $c, $reqspec, @args) = @_;
847    my @message;
848    $reqspec->{src} = 0;
849
850    @args = @{ $c->forward('_getopt', [
851        {
852            'd=s' => \$reqspec->{distribution},
853            'v=s' => \$reqspec->{release},
854            'r=s' => \$reqspec->{release},
855            'a=s' => \$reqspec->{arch},
856            's'   => sub { $reqspec->{src} = 1 },
857        }, @args ]) };
858    if ($c->stash->{getopt_error}) {
859        return $c->stash->{xmlrpc};
860    }
861
862    @args == 2 or do {
863        $c->error('No argument given');
864        return;
865    };
866
867    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
868        return $c->stash->{xmlrpc} = {
869            message => [ "I don't have such distribution : "
870                    .$c->forward('_fmt_question', [$reqspec])],
871        };
872    }
873
874    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
875    if (!@{ $rpmlist }) {
876        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
877        if ($else) {
878            return $c->stash->{xmlrpc} = {
879                message => [ 
880                    "There is no rpm named `$args[0]' in "
881                    .$c->forward('_fmt_question', [$reqspec])
882                    .", but the word matches in " . $else
883                ],
884            }
885        } else {
886            return $c->stash->{xmlrpc} = {
887                message => [ "The rpm named `$args[0]' has not been found in "
888                    .$c->forward('_fmt_question', [$reqspec])],
889            }
890        }
891    }
892    foreach (@{ $rpmlist }) {
893        my $info = $c->forward('/rpms/queryformat', [ $_, $args[1] ]);
894        push @message, $info . ' // ' .
895            $c->forward('_fmt_location', [ $reqspec, $_ ]);
896    }
897    return $c->stash->{xmlrpc} = {
898        message => \@message,
899    }
900}
901
902=head2 more [-d distrib] [-r release] [-a arch] [-s]  NAME
903
904Show url where details about package named C<NAME> can be found
905
906=cut
907
908sub more : XMLRPC {
909    my ($self, $c, $reqspec, @args) = @_;
910    my @message;
911    $reqspec->{src} = 0;
912
913    @args = @{ $c->forward('_getopt', [
914        {
915            'd=s' => \$reqspec->{distribution},
916            'v=s' => \$reqspec->{release},
917            'r=s' => \$reqspec->{release},
918            'a=s' => \$reqspec->{arch},
919            's'   => sub { $reqspec->{src} = 1 },
920        }, @args ]) };
921    if ($c->stash->{getopt_error}) {
922        return $c->stash->{xmlrpc};
923    }
924
925    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
926        return $c->stash->{xmlrpc} = {
927            message => [ "I don't have such distribution : "
928                    .$c->forward('_fmt_question', [$reqspec])],
929        };
930    }
931
932    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
933    if (!@{ $rpmlist }) {
934        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
935        if ($else) {
936            return $c->stash->{xmlrpc} = {
937                message => [ 
938                    "There is no rpm named `$args[0]' in "
939                    .$c->forward('_fmt_question', [$reqspec])
940                    .", but the word matches in " . $else
941                ],
942            }
943        } else {
944            return $c->stash->{xmlrpc} = {
945                message => [ "The rpm named `$args[0]' has not been found in "
946                    .$c->forward('_fmt_question', [$reqspec])],
947            }
948        }
949    }
950    foreach (@{ $rpmlist }) {
951        push @message, $c->uri_for('/rpms', $_) . ' // ' .
952            $c->forward('_fmt_location', [ $reqspec, $_ ]);
953    }
954    return $c->stash->{xmlrpc} = {
955        message => \@message,
956    }
957}
958
959=head2 buildfrom [-d distrib] [-r release] [-a arch] NAME
960
961Return the list of package build from source package named C<NAME>
962
963=cut
964
965sub buildfrom : XMLRPC {
966    my ($self, $c, $reqspec, @args) = @_;
967    $reqspec->{src} = 1;
968    my @message;
969    @args = @{ $c->forward('_getopt', [
970        {
971            'd=s' => \$reqspec->{distribution},
972            'v=s' => \$reqspec->{release},
973            'r=s' => \$reqspec->{release},
974            'a=s' => \$reqspec->{arch},
975        }, @args ]) };
976    if ($c->stash->{getopt_error}) {
977        return $c->stash->{xmlrpc};
978    }
979
980    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
981        return $c->stash->{xmlrpc} = {
982            message => [ "I don't have such distribution in "
983                    .$c->forward('_fmt_question', [$reqspec])],
984        };
985    }
986    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
987    if (!@{ $rpmlist }) {
988        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
989        if ($else) {
990            return $c->stash->{xmlrpc} = {
991                message => [ 
992                    "There is no rpm named `$args[0]' in "
993                    .$c->forward('_fmt_question', [$reqspec])
994                    .", but the word matches in " . $else
995                ],
996            }
997        } else {
998            return $c->stash->{xmlrpc} = {
999                message => [ "The rpm named `$args[0]' has not been found in "
1000                    .$c->forward('_fmt_question', [$reqspec])],
1001            }
1002        }
1003    }
1004    foreach (@{ $rpmlist }) {
1005        my $res = $c->forward('/rpms/binaries', [ $_ ]);
1006        my @name;
1007        foreach (@$res) {
1008            push(@name, $c->forward('/rpms/basicinfo', [ $_ ])->{name});
1009        }
1010        push(@message, join(', ', sort @name));
1011    }
1012    return $c->stash->{xmlrpc} = {
1013        message => \@message,
1014    }
1015
1016}
1017
1018=head2 findfile [-d distrib] [-r release] [-a arch] [-s] FILE
1019
1020Return the rpm owning the file C<FILE>.
1021
1022=cut
1023
1024sub findfile : XMLRPC {
1025    my ($self, $c, $reqspec, @args) = @_;
1026
1027    my @message;
1028    $reqspec->{src} = 0;
1029
1030    @args = @{ $c->forward('_getopt', [
1031        {
1032            'd=s' => \$reqspec->{distribution},
1033            'v=s' => \$reqspec->{release},
1034            'r=s' => \$reqspec->{release},
1035            'a=s' => \$reqspec->{arch},
1036            's'   => \$reqspec->{src},
1037        }, @args ]) };
1038    if ($c->stash->{getopt_error}) {
1039        return $c->stash->{xmlrpc};
1040    }
1041
1042    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
1043        return $c->stash->{xmlrpc} = {
1044            message => [ "I don't have such distribution in "
1045                    .$c->forward('_fmt_question', [$reqspec])],
1046        };
1047    }
1048
1049    my $rpmlist = $c->forward('/search/rpm/byfile', [ $reqspec, $args[0] ]);
1050    if (!@{ $rpmlist }) {
1051        return $c->stash->{xmlrpc} = {
1052            message => [ "Sorry, no file $args[0] found in "
1053                    .$c->forward('_fmt_question', [$reqspec])],
1054        }
1055    } elsif (@{ $rpmlist } > 20) {
1056        foreach (@{ $rpmlist }) {
1057            my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
1058            push @message, $info->{name} . ' // ' .
1059                $c->forward('_fmt_location', [ $reqspec, $_ ]);
1060        }
1061        return $c->stash->{xmlrpc} = {
1062            message => ["find in "
1063                    .$c->forward('_fmt_question', [$reqspec])
1064                    ." :",
1065                    @message],
1066        }
1067    } else {
1068        my %list;
1069        foreach (@{ $rpmlist }) {
1070            my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
1071            $list{$info->{name}} = 1;
1072        }
1073        return $c->stash->{xmlrpc} = {
1074            message => ["find in "
1075                    .$c->forward('_fmt_question', [$reqspec])
1076                    ." : ".join(', ', sort keys %list) ],
1077        };
1078    }
1079}
1080
1081=head2 what [-d distrib] [-r release] [-a arch] [-s] p|r|c|o|e|s DEP [SENSE [EVR]]
1082
1083Search rpm matching having matching dependencies (provides, requires, conflicts,
1084obsoletes, enhanced or suggests)
1085
1086=cut
1087
1088sub what : XMLRPC {
1089    my ($self, $c, $reqspec, @args) = @_;
1090       
1091    @args = @{ $c->forward('_getopt', [
1092        {
1093            'd=s' => \$reqspec->{distribution},
1094            'v=s' => \$reqspec->{release},
1095            'r=s' => \$reqspec->{release},
1096            'a=s' => \$reqspec->{arch},
1097            's'   => \$reqspec->{src},
1098        }, @args ]) };
1099    if ($c->stash->{getopt_error}) {
1100        return $c->stash->{xmlrpc};
1101    }
1102
1103    my ($type, $depname, $sense, $evr) = @args;
1104
1105    my $deptype = uc(substr($type, 0, 1));
1106    my $rpmlist = $c->forward('/search/rpm/bydep',
1107        [ $reqspec, $deptype, $depname, $sense, $evr ]);
1108
1109    if (@{ $rpmlist } < 20) {
1110        my @name;
1111        foreach (@{ $rpmlist }) {
1112            my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
1113            push @name, $info->{name} . '-' . $info->{evr};
1114        }
1115        return $c->stash->{xmlrpc} = {
1116            message => [
1117                "Package matching $depname" . ($evr ? " $sense $evr" : '') .
1118                " in "
1119                .$c->forward('_fmt_question', [$reqspec])
1120                .':', 
1121                join(' ', @name),
1122            ],
1123        }
1124    } else {
1125        return $c->stash->{xmlrpc} = {
1126            message => [ 'Too many results in ' 
1127                    .$c->forward('_fmt_question', [$reqspec])],
1128        };
1129    }
1130
1131}
1132
1133=head2 maint [-d distrib] [-r release] [-a arch] [-s] RPMNAME
1134
1135Show the maintainers for the rpm named C<RPMNAME>.
1136
1137=cut
1138
1139sub maint : XMLRPC {
1140    my ($self, $c, $reqspec, @args) = @_;
1141    $reqspec->{src} = 0;
1142    my @message;
1143    @args = @{ $c->forward('_getopt', [
1144        {
1145            'd=s' => \$reqspec->{distribution},
1146            'v=s' => \$reqspec->{release},
1147            'r=s' => \$reqspec->{release},
1148            'a=s' => \$reqspec->{arch},
1149            's'   => \$reqspec->{src},
1150        }, @args ]) };
1151    if ($c->stash->{getopt_error}) {
1152        return $c->stash->{xmlrpc};
1153    }
1154
1155    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
1156        return $c->stash->{xmlrpc} = {
1157            message => [ "I don't have such distribution : " 
1158                    .$c->forward('_fmt_question', [$reqspec])],
1159        };
1160    }
1161    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
1162    if (!@{ $rpmlist }) {
1163        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
1164        if ($else) {
1165            return $c->stash->{xmlrpc} = {
1166                message => [ 
1167                    "There is no rpm named `$args[0]' in "
1168                    .$c->forward('_fmt_question', [$reqspec])
1169                    .", but the word matches in " . $else
1170                ],
1171            }
1172        } else {
1173            return $c->stash->{xmlrpc} = {
1174                message => [ "The rpm named `$args[0]' has not been found in "
1175                    .$c->forward('_fmt_question', [$reqspec])],
1176            }
1177        }
1178    }
1179    my %maint;
1180    foreach (@{ $rpmlist }) {
1181        my $res = $c->forward('/rpms/maintainers', [ $_ ]);
1182        foreach (@$res) {
1183            my $m = 'For ' . $_->{vendor} . ': ' . $_->{owner};
1184            $maint{$m} = 1;
1185        }
1186    }
1187    return $c->stash->{xmlrpc} = {
1188        message => [ sort keys %maint ],
1189    }
1190}
1191
1192=head2 nb_rpm [-d distrib] NAME
1193
1194Show the count of rpm maintains by packager matching C<NAME>.
1195
1196=cut
1197
1198sub nb_rpm : XMLRPC {
1199    my ($self, $c, $reqspec, @args) = @_;
1200    my @message;
1201    my $dist = { distribution => $reqspec->{distribution} };
1202    @args = @{ $c->forward('_getopt', [
1203        {
1204            'd=s' => \$dist->{distribution},
1205        }, @args ]) };
1206    if ($c->stash->{getopt_error}) {
1207        return $c->stash->{xmlrpc};
1208    }
1209
1210    if (!$c->forward('/distrib/exists', [ $dist ])) {
1211        return $c->stash->{xmlrpc} = {
1212            message => [ "I don't have such distribution : "
1213                    .$c->forward('_fmt_question', [$reqspec])],
1214        };
1215    }
1216
1217    my $maints = $c->forward('/maintainers/search',
1218        [ $args[0], $dist->{distribution} ]);
1219    if (@$maints > 3) {
1220        return $c->stash->{xmlrpc} = {
1221            message => [ 
1222                scalar(@$maints) . " maintainers found matching `$args[0]' in "
1223                    .$c->forward('_fmt_question', [$reqspec])],
1224        };
1225    } elsif (! @$maints) {
1226        return $c->stash->{xmlrpc} = {
1227            message => [ "No maintainer found matching `$args[0]' in " 
1228                    .$c->forward('_fmt_question', [$reqspec])],
1229        };
1230    } else {
1231        my @messages;
1232        foreach (@$maints) {
1233            my $rpms = $c->forward('/maintainers/bymaintainer', [
1234                $_->{owner}, $dist->{distribution} ]);
1235            push(@messages, sprintf('%s (%s) maintains %d rpms',
1236                    $_->{owner},
1237                    $_->{vendor},
1238                    scalar(@$rpms),
1239                )
1240            );
1241        }
1242        return $c->stash->{xmlrpc} = {
1243            message => \@messages,
1244        };
1245    }
1246}
1247
1248=head1 AUTHOR
1249
1250Olivier Thauvin
1251
1252=head1 LICENSE
1253
1254This library is free software. You can redistribute it and/or modify
1255it under the same terms as Perl itself.
1256
1257=cut
1258
1259__PACKAGE__->meta->make_immutable;
1260
12611;
Note: See TracBrowser for help on using the repository browser.