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

Last change on this file since 432 was 432, checked in by grenoya, 12 years ago
  • add the possibility to use 'distrib' parameter to set and unset functions
  • inform about the 'list' command when the user tries to set without giving a value
  • Property svn:keywords set to Id Rev
File size: 33.8 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 there is no variable to fix, Sophie ask and stop
200    if (!$var) {
201        return $c->stash->{xmlrpc} = {
202            private_reply => 1,
203            message => [
204                "What must I set ? possible parameters are : " . 
205                    "'distribution', 'release' and 'arch'."
206            ]
207        }
208    } 
209   
210    # if the variable is not 'distribution', 'distrib', 'release' or 'arch', Sophie
211    # complains and stop
212    if ($var ne "distribution" && $var ne "release" && $var ne "arch") {
213        # in order not to implement 'distrib' on the server, $var is changes
214        # into 'distribution'
215        if ($var eq "distrib") {
216            $var = "distribution";
217        } else {
218            return $c->stash->{xmlrpc} = {
219                private_reply => 1,
220                message => [
221                    "'$var' is not valid ! possible parameters are : " . 
222                        "'distribution', 'release' and 'arch'."
223                ]
224            }
225        }
226    }
227
228    # if there is no value to give to the variable, Sophie ask and stop
229    if (!$val) {
230        # the message will depend on the actual settings of the user: the answer
231        # contains the command to ask Sophie the possibilities
232        my $msgtmp = "To what must I set $var ? (use 'list";
233        my $msgfin = "' to see the possibilities)";
234
235        if ($var ne "distribution") {
236            # the message is built using the user's pref
237            my $res = $c->forward('/user/fetchdata', [ $reqspec->{from}, ]);
238            my $owndistrib = $res->{"distribution"} || '(none)';
239            if ($var eq "release" && $owndistrib eq '(none)') {
240                    $msgtmp = "Release depends on Distribution. Use 'list" .
241                        "' to see the possibilities";
242                    $msgfin = "";
243            } else {
244                $msgtmp .= " ".$owndistrib;
245
246                if ($var eq "arch") {
247                    my $ownrelease = $res->{"release"} || '(none)';
248                    if ($ownrelease eq '(none)') {
249                        $msgtmp = "Arch depends on Release. Use 'list " .
250                            $owndistrib."' to see the possibilities";
251                        $msgfin = "";
252                    } else {
253                        $msgtmp .= " ".$ownrelease;
254                    }
255                }
256            }
257        }
258
259        return $c->stash->{xmlrpc} = {
260            private_reply => 1,
261            message => [
262                $msgtmp.$msgfin
263            ]
264        }
265    } 
266   
267    $c->forward('/user/update_data', [ $reqspec->{from}, { $var => $val } ]);
268
269    return $c->stash->{xmlrpc} = {
270        private_reply => 1,
271        message => [
272            "$var set to: " . ($val || '(none)'),
273            ($c->forward('/distrib/exists', [
274                    $c->forward('/user/fetchdata', [ $reqspec->{from}, ]) ])
275                ? ()
276                : ("warning: your setting does not match any distribution")
277            ),
278        ]
279    };
280}
281
282=head2 unset [distribution|release|arch]
283
284Unset default search value (see also: set)
285
286=cut
287
288sub unset : XMLRPC {
289    my ( $self, $c, $reqspec, $var ) = @_;
290
291    # if there is no variable to fix, Sophie ask and stop
292    if (!$var) {
293        return $c->stash->{xmlrpc} = {
294            private_reply => 1,
295            message => [
296                "What must I unset ?"
297            ]
298        }
299    } 
300   
301    # if the variable is not 'distribution', 'distrib', 'release' or 'arch', Sophie
302    # complains and stop
303    if ($var ne "distribution" && $var ne "release" && $var ne "arch") {
304        # in order not to implement 'distrib' on the server, $var is changes
305        # into 'distribution'
306        if ($var eq "distrib") {
307            $var = "distribution";
308        } else {
309            return $c->stash->{xmlrpc} = {
310                private_reply => 1,
311                message => [
312                    "'$var' is not valid ! possible parameters are : " .
313                    "'distribution', 'release' and 'arch'."
314                ]
315            }
316        }
317    }
318
319    $c->forward('/user/update_data', [ $reqspec->{from}, { $var => undef } ]);
320   
321    return $c->stash->{xmlrpc} = {
322        private_reply => 1,
323        message => [ "$var set to: (none)" ],
324    };
325}
326
327=head2 show [var]
328
329Show your user settings
330
331=cut
332
333sub show : XMLRPC {
334    my ( $self, $c, $reqspec, $var, ) = @_;
335
336    my $res = $c->forward('/user/fetchdata', [ $reqspec->{from}, ]);
337   
338    if ($var) {
339        my $own = $res->{$var} || '(none)';
340        my $applied = $reqspec->{$var} || '(none)';
341        return $c->stash->{xmlrpc} = {
342            message => [ sprintf("%s is set to %s%s",
343                $var,
344                $own,
345                ($own ne $applied
346                    ? " ($applied is used in this context)"
347                    : '')
348            ) ]
349        };
350    } else {
351        my $own = $c->forward('_fmt_question', [$res]);
352        my $applied = $c->forward('_fmt_question', [$reqspec]);
353
354        return $c->stash->{xmlrpc} = {
355            message => [ sprintf('your setting is: %s%s',
356                $own,
357                ($own ne $applied
358                    ? " ($applied is used in this context)"
359                    : ''
360                )
361            ),
362            ($c->forward('/distrib/exists', [ $res ])
363                ? ()
364                : ("warning: your setting does not match any distribution")
365            )
366            ],
367        }
368    }
369}
370
371=head2 asv
372
373ASV means in french "age, sexe, ville" (age, sex and town).
374Return the version of the Chat module version.
375
376=cut
377
378sub asv : XMLRPC {
379    my ( $self, $c ) = @_;
380    return $c->stash->{xmlrpc} = {
381        message => [ 'Sophie: ' . $Sophie::VERSION . ', Chat ' . q$Rev$ ],
382    };
383}
384
385=head2 list [distribution [release [arch]]]
386
387List available distribution, release, architecture matching given arguments.
388
389=cut
390
391sub list : XMLRPC {
392    my ($self, $c, $reqspec, @args) = @_;
393
394    my $distrib = {
395        distribution => $args[0],
396        release      => $args[1],
397        arch         => $args[2],
398    };
399
400    if (!$c->forward('/distrib/exists', [ $distrib ])) {
401        return $c->stash->{xmlrpc} = {
402            message => [ "I don't have any distribution matching: "
403                         . join(' / ', grep { $_ } @args[0..2]) ],
404        };
405    }
406
407    my @list = @{ $c->forward('/distrib/list', [ $distrib ]) };
408    return $c->stash->{xmlrpc} = {
409        message => [ 
410            ($args[0] 
411                ? join(' / ', grep { $_ } @args[0..2]) . ': '
412                : '') .
413            join(', ', @list) ],
414    }
415}
416
417=head2 q [-d distrib] [-r release] [-a arch] [-s]  REGEXP
418
419Search rpm name matching C<REGEXP>.
420
421NB: C<.>, C<*>, C<+> have special meaning
422and have to be escaped.
423
424=cut
425
426sub q : XMLRPC {
427    my ($self, $c, $reqspec, @args) = @_;
428
429    $reqspec->{src} = 0;
430
431    @args = @{ $c->forward('_getopt', [
432        {
433            'd=s' => \$reqspec->{distribution},
434            'v=s' => \$reqspec->{release},
435            'r=s' => \$reqspec->{release},
436            'a=s' => \$reqspec->{arch},
437            's'   => sub { $reqspec->{src} = 1 },
438        }, @args ]) };
439
440    if ($c->stash->{getopt_error}) {
441        return $c->stash->{xmlrpc};
442    }
443
444    my $res = $c->forward('/search/tags/name_regexp', [ $reqspec, $args[0] ]);
445    if (!@{ $res }) {
446        return $c->stash->{xmlrpc} = {
447            message => [ "Nothing matches `$args[0]' in "
448                    .$c->forward('_fmt_question', [$reqspec])],
449        };
450    } else {
451        my @message = "rpm name matching `$args[0]' in "
452                    .$c->forward('_fmt_question', [$reqspec])." :";
453        while (@{ $res }) {
454            my $str = '';
455            while (length($str) < 70) {
456                my $item = shift(@{ $res }) or last;
457                $str .= ', ' if ($str);
458                $str .= $item->{name};
459            }
460            push(@message, $str);
461        }
462        return $c->stash->{xmlrpc} = {
463            message => \@message,
464        };
465    }
466}
467
468=head2 whatis [-d distrib] [-r release] [-a arch] [-s]  WORD [WORD2 [...]]
469
470Search rpm having description containing words given as arguments
471
472=cut
473
474sub whatis : XMLRPC {
475    my ($self, $c, $reqspec, @args) = @_;
476
477    $reqspec->{src} = 0;
478
479    @args = @{ $c->forward('_getopt', [
480        {
481            'd=s' => \$reqspec->{distribution},
482            'v=s' => \$reqspec->{release},
483            'r=s' => \$reqspec->{release},
484            'a=s' => \$reqspec->{arch},
485            's'   => sub { $reqspec->{src} = 1 },
486        }, @args ]) };
487    if ($c->stash->{getopt_error}) {
488        return $c->stash->{xmlrpc};
489    }
490
491    my $res = $c->forward('/search/rpm/description', [ $reqspec, @args ]);
492
493    if (@{ $res }) {
494        if (@{ $res } > 100) {
495            return $c->stash->{xmlrpc} = {
496                message => [ 'I have ' . @{ $res } . ' results in '
497                    .$c->forward('_fmt_question', [$reqspec])],
498            };
499        } else {
500            my @names = ();
501            foreach (@{ $res }) {
502                my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
503                push(@names, $info->{name});
504            }
505            my @message = "rpm name matching `$args[0]' in "
506                    .$c->forward('_fmt_question', [$reqspec])." :";
507            while (@names) {
508                my $str = '';
509                while (length($str) < 70) {
510                    my $item = shift(@names) or last;
511                    $str .= ', ' if ($str);
512                    $str .= $item;
513                }
514                push(@message, $str);
515            }
516            return $c->stash->{xmlrpc} = {
517                message => \@message,
518            };
519        }
520    } else {
521        return $c->stash->{xmlrpc} = {
522            message => [ 'No rpm description matches this keywords in '
523                    .$c->forward('_fmt_question', [$reqspec])],
524        };
525    }
526}
527
528=head2 version [-d distrib] [-r release] [-a arch] [-s] NAME
529
530Show the version of package C<NAME>.
531
532=cut
533
534sub version : XMLRPC {
535    my ($self, $c, $reqspec, @args) = @_;
536
537    my @message;
538    $reqspec->{src} = 0;
539
540    @args = @{ $c->forward('_getopt', [
541        {
542            'd=s' => \$reqspec->{distribution},
543            'v=s' => \$reqspec->{release},
544            'r=s' => \$reqspec->{release},
545            'a=s' => \$reqspec->{arch},
546            's'   => sub { $reqspec->{src} = 1 },
547        }, @args ]) };
548    if ($c->stash->{getopt_error}) {
549        return $c->stash->{xmlrpc};
550    }
551
552    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
553        return $c->stash->{xmlrpc} = {
554            message => [ "I don't have such distribution : " 
555                    .$c->forward('_fmt_question', [$reqspec])],
556        };
557    }
558
559    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
560    if (!@{ $rpmlist }) {
561        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
562        if ($else) {
563            return $c->stash->{xmlrpc} = {
564                message => [ 
565                    "There is no rpm named `$args[0]' in "
566                    .$c->forward('_fmt_question', [$reqspec])
567                    .", but the word matches in " . $else
568                ],
569            }
570        } else {
571            return $c->stash->{xmlrpc} = {
572                message => [ "The rpm named `$args[0]' has not been found in "
573                    .$c->forward('_fmt_question', [$reqspec])],
574            }
575        }
576    }
577    foreach (@{ $rpmlist }) {
578        my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
579        push @message, $info->{evr} . ' // ' .
580            $c->forward('_fmt_location', [ $reqspec, $_ ]);
581    }
582    return $c->stash->{xmlrpc} = {
583        message => [ @message ],
584    }
585}
586
587=head2 v
588
589C<v> is an alias for C<version> command.
590
591=cut
592
593sub v : XMLRPC {
594    my ($self, $c, @args) = @_;
595    $c->forward('version', [ @args ]);
596}
597
598=head2 summary [-d distrib] [-r release] [-a arch] [-s]  NAME
599
600Show the summary of package C<NAME>.
601
602=cut
603
604sub summary : XMLRPC {
605    my ($self, $c, $reqspec, @args) = @_;
606
607    $c->forward('qf', [ $reqspec, @args, '%{summary}' ]);
608}
609
610=head2 s
611
612Is an alias for C<summary> command.
613
614=cut
615
616sub s : XMLRPC {
617    my ($self, $c, @args) = @_;
618    $c->forward('summary', [ @args ]);
619}
620
621=head2 packager [-d distrib] [-r release] [-a arch] [-s]  NAME
622
623Show the packager of package C<NAME>.
624
625=cut
626
627sub packager : XMLRPC {
628    my ($self, $c, $reqspec, @args) = @_;
629
630    $c->forward('qf', [ $reqspec, @args, '%{packager}' ]);
631}
632
633=head2 p
634
635Is an alias for C<packager> command.
636
637=cut
638
639sub p : XMLRPC {
640    my ($self, $c, @args) = @_;
641    $c->forward('packager', [ @args ]);
642}
643
644=head2 arch [-d distrib] [-r release] [-a arch] [-s]  NAME
645
646Show the architecture of package C<NAME>.
647
648=cut 
649
650sub arch : XMLRPC {
651    my ($self, $c, $reqspec, @args) = @_;
652
653    $c->forward('qf', [ $reqspec, @args, '%{arch}' ]);
654}
655
656=head2 a
657
658Is an alias to C<arch> command.
659
660=cut 
661
662sub a : XMLRPC {
663    my ($self, $c, @args) = @_;
664    $c->forward('arch', [ @args ]);
665}
666
667=head2 url [-d distrib] [-r release] [-a arch] [-s]  NAME
668
669Show the url of package C<NAME>.
670
671=cut 
672
673sub url : XMLRPC {
674    my ($self, $c, $reqspec, @args) = @_;
675
676    $c->forward('qf', [ $reqspec, @args, '%{url}' ]);
677}
678
679=head2 u
680
681Is an alias to C<url> command.
682
683=cut 
684
685sub u : XMLRPC {
686    my ($self, $c, @args) = @_;
687    $c->forward('url', [ @args ]);
688}
689
690=head2 group [-d distrib] [-r release] [-a arch] [-s] NAME
691
692Show the group of package C<NAME>.
693
694=cut 
695
696sub group : XMLRPC {
697    my ($self, $c, $reqspec, @args) = @_;
698
699    $c->forward('qf', [ $reqspec, @args, '%{group}' ]);
700}
701
702=head2 g
703
704Is an alias to C<group> command.
705
706=cut 
707
708sub g : XMLRPC {
709    my ($self, $c, @args) = @_;
710    $c->forward('group', [ @args ]);
711}
712
713=head2 license [-d distrib] [-r release] [-a arch] [-s] NAME
714
715Show the license of package C<NAME>.
716
717=cut 
718
719sub license : XMLRPC {
720    my ($self, $c, $reqspec, @args) = @_;
721
722    $c->forward('qf', [ $reqspec, @args, '%{license}' ]);
723}
724
725=head2 l
726
727Is an alias to C<license> command.
728
729=cut 
730
731sub l : XMLRPC {
732    my ($self, $c, @args) = @_;
733    $c->forward('license', [ @args ]);
734}
735
736=head2 buildtime [-d distrib] [-r release] [-a arch] [-s] NAME
737
738Show the build time of package C<NAME>.
739
740=cut
741
742sub buildtime : XMLRPC {
743    my ($self, $c, $reqspec, @args) = @_;
744
745    $c->forward('qf', [ $reqspec, @args, '%{buildtime:date}' ]);
746}
747
748=head2 builddate
749
750Is an alias for C<buildtime> command.
751
752=cut
753
754sub builddate : XMLRPC {
755    my ($self, $c, @args) = @_;
756    $c->forward('buildtime', [ @args ]);
757}
758
759=head2 b
760
761Is an alias for C<buildtime> command.
762
763=cut
764
765sub b : XMLRPC {
766    my ($self, $c, @args) = @_;
767    $c->forward('builddate', [ @args ]);
768}
769
770=head2 cookie [-d distrib] [-r release] [-a arch] [-s]  NAME
771
772Show the C<cookie> tag of package C<NAME>.
773
774=cut
775
776sub cookie : XMLRPC {
777    my ($self, $c, $reqspec, @args) = @_;
778
779    $c->forward('qf', [ $reqspec, @args, '%{cookie}' ]);
780}
781
782=head2 sourcerpm [-d distrib] [-r release] [-a arch] [-s] NAME
783
784Show the C<sourcerpm> tag of package C<NAME>.
785
786=cut
787
788sub sourcerpm : XMLRPC {
789    my ($self, $c, $reqspec, @args) = @_;
790
791    $c->forward('qf', [ $reqspec, @args, '%{sourcerpm}' ]);
792}
793
794=head2 src NAME
795
796Is an alias for C<sourcerpm> command.
797
798=cut
799
800sub src : XMLRPC {
801    my ($self, $c, $reqspec, @args) = @_;
802
803    $c->forward('sourcerpm', [ $reqspec, @args ]);
804}
805
806=head2 rpmversion [-d distrib] [-r release] [-a arch] [-s] NAME
807
808Show the C<rpmversion> tag of package C<NAME>.
809
810=cut
811
812sub rpmversion : XMLRPC {
813    my ($self, $c, $reqspec, @args) = @_;
814
815    $c->forward('qf', [ $reqspec, @args, '%{rpmversion}' ]);
816}
817
818=head2 rpmbuildversion NAME
819
820Is an alias for C<rpmversion> command.
821
822=cut
823
824sub rpmbuildversion : XMLRPC {
825    my ($self, $c, $reqspec, @args) = @_;
826
827    $c->forward('rpmversion', [ $reqspec, @args ]);
828}
829
830
831=head2 buildhost [-d distrib] [-r release] [-a arch] [-s] NAME
832
833Show the C<buildhost> tag of package C<NAME>.
834
835=cut
836
837sub buildhost : XMLRPC {
838    my ($self, $c, $reqspec, @args) = @_;
839
840    $c->forward('qf', [ $reqspec, @args, '%{buildhost}' ]);
841}
842
843=head2 host NAME
844
845Is an alias for C<buildhost> command.
846
847=cut
848
849sub host : XMLRPC {
850    my ($self, $c, $reqspec, @args) = @_;
851
852    $c->forward('host', [ $reqspec, @args ]);
853}
854
855=head2 h NAME
856
857Is an alias for C<buildhost> command.
858
859=cut
860
861sub h : XMLRPC {
862    my ($self, $c, $reqspec, @args) = @_;
863
864    $c->forward('host', [ $reqspec, @args ]);
865}
866
867
868
869=head2 distribution [-d distrib] [-r release] [-a arch] [-s] NAME
870
871Show the C<distribution> tag of package C<NAME>.
872
873=cut
874
875sub distribution : XMLRPC {
876    my ($self, $c, $reqspec, @args) = @_;
877
878    $c->forward('qf', [ $reqspec, @args, '%{distribution}' ]);
879}
880
881=head2 distrib NAME
882
883Is an alias for C<distribution> command.
884
885=cut
886
887sub distrib : XMLRPC {
888    my ($self, $c, $reqspec, @args) = @_;
889
890    $c->forward('distribution', [ $reqspec, @args ]);
891}
892
893
894
895=head2 vendor [-d distrib] [-r release] [-a arch] [-s] NAME
896
897Show the C<vendor> tag of package C<NAME>.
898
899=cut
900
901sub vendor : XMLRPC {
902    my ($self, $c, $reqspec, @args) = @_;
903
904    $c->forward('qf', [ $reqspec, @args, '%{vendor}' ]);
905}
906
907=head2 qf [-d distrib] [-r release] [-a arch] [-s] NAME FMT
908
909Perform an rpm -q --qf C<FMT> on package C<NAME>.
910
911=cut
912
913sub qf : XMLRPC {
914    my ($self, $c, $reqspec, @args) = @_;
915    my @message;
916    $reqspec->{src} = 0;
917
918    @args = @{ $c->forward('_getopt', [
919        {
920            'd=s' => \$reqspec->{distribution},
921            'v=s' => \$reqspec->{release},
922            'r=s' => \$reqspec->{release},
923            'a=s' => \$reqspec->{arch},
924            's'   => sub { $reqspec->{src} = 1 },
925        }, @args ]) };
926    if ($c->stash->{getopt_error}) {
927        return $c->stash->{xmlrpc};
928    }
929
930    @args == 2 or do {
931        $c->error('No argument given');
932        return;
933    };
934
935    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
936        return $c->stash->{xmlrpc} = {
937            message => [ "I don't have such distribution : "
938                    .$c->forward('_fmt_question', [$reqspec])],
939        };
940    }
941
942    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
943    if (!@{ $rpmlist }) {
944        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
945        if ($else) {
946            return $c->stash->{xmlrpc} = {
947                message => [ 
948                    "There is no rpm named `$args[0]' in "
949                    .$c->forward('_fmt_question', [$reqspec])
950                    .", but the word matches in " . $else
951                ],
952            }
953        } else {
954            return $c->stash->{xmlrpc} = {
955                message => [ "The rpm named `$args[0]' has not been found in "
956                    .$c->forward('_fmt_question', [$reqspec])],
957            }
958        }
959    }
960    foreach (@{ $rpmlist }) {
961        my $info = $c->forward('/rpms/queryformat', [ $_, $args[1] ]);
962        push @message, $info . ' // ' .
963            $c->forward('_fmt_location', [ $reqspec, $_ ]);
964    }
965    return $c->stash->{xmlrpc} = {
966        message => \@message,
967    }
968}
969
970=head2 more [-d distrib] [-r release] [-a arch] [-s]  NAME
971
972Show url where details about package named C<NAME> can be found
973
974=cut
975
976sub more : XMLRPC {
977    my ($self, $c, $reqspec, @args) = @_;
978    my @message;
979    $reqspec->{src} = 0;
980
981    @args = @{ $c->forward('_getopt', [
982        {
983            'd=s' => \$reqspec->{distribution},
984            'v=s' => \$reqspec->{release},
985            'r=s' => \$reqspec->{release},
986            'a=s' => \$reqspec->{arch},
987            's'   => sub { $reqspec->{src} = 1 },
988        }, @args ]) };
989    if ($c->stash->{getopt_error}) {
990        return $c->stash->{xmlrpc};
991    }
992
993    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
994        return $c->stash->{xmlrpc} = {
995            message => [ "I don't have such distribution : "
996                    .$c->forward('_fmt_question', [$reqspec])],
997        };
998    }
999
1000    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
1001    if (!@{ $rpmlist }) {
1002        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
1003        if ($else) {
1004            return $c->stash->{xmlrpc} = {
1005                message => [ 
1006                    "There is no rpm named `$args[0]' in "
1007                    .$c->forward('_fmt_question', [$reqspec])
1008                    .", but the word matches in " . $else
1009                ],
1010            }
1011        } else {
1012            return $c->stash->{xmlrpc} = {
1013                message => [ "The rpm named `$args[0]' has not been found in "
1014                    .$c->forward('_fmt_question', [$reqspec])],
1015            }
1016        }
1017    }
1018    foreach (@{ $rpmlist }) {
1019        push @message, $c->uri_for('/rpms', $_) . ' // ' .
1020            $c->forward('_fmt_location', [ $reqspec, $_ ]);
1021    }
1022    return $c->stash->{xmlrpc} = {
1023        message => \@message,
1024    }
1025}
1026
1027=head2 buildfrom [-d distrib] [-r release] [-a arch] NAME
1028
1029Return the list of package build from source package named C<NAME>
1030
1031=cut
1032
1033sub buildfrom : XMLRPC {
1034    my ($self, $c, $reqspec, @args) = @_;
1035    $reqspec->{src} = 1;
1036    my @message;
1037    @args = @{ $c->forward('_getopt', [
1038        {
1039            'd=s' => \$reqspec->{distribution},
1040            'v=s' => \$reqspec->{release},
1041            'r=s' => \$reqspec->{release},
1042            'a=s' => \$reqspec->{arch},
1043        }, @args ]) };
1044    if ($c->stash->{getopt_error}) {
1045        return $c->stash->{xmlrpc};
1046    }
1047
1048    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
1049        return $c->stash->{xmlrpc} = {
1050            message => [ "I don't have such distribution in "
1051                    .$c->forward('_fmt_question', [$reqspec])],
1052        };
1053    }
1054    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
1055    if (!@{ $rpmlist }) {
1056        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
1057        if ($else) {
1058            return $c->stash->{xmlrpc} = {
1059                message => [ 
1060                    "There is no rpm named `$args[0]' in "
1061                    .$c->forward('_fmt_question', [$reqspec])
1062                    .", but the word matches in " . $else
1063                ],
1064            }
1065        } else {
1066            return $c->stash->{xmlrpc} = {
1067                message => [ "The rpm named `$args[0]' has not been found in "
1068                    .$c->forward('_fmt_question', [$reqspec])],
1069            }
1070        }
1071    }
1072    foreach (@{ $rpmlist }) {
1073        my $res = $c->forward('/rpms/binaries', [ $_ ]);
1074        my @name;
1075        foreach (@$res) {
1076            push(@name, $c->forward('/rpms/basicinfo', [ $_ ])->{name});
1077        }
1078        push(@message, join(', ', sort @name));
1079    }
1080    return $c->stash->{xmlrpc} = {
1081        message => \@message,
1082    }
1083
1084}
1085
1086=head2 findfile [-d distrib] [-r release] [-a arch] [-s] FILE
1087
1088Return the rpm owning the file C<FILE>.
1089
1090=cut
1091
1092sub findfile : XMLRPC {
1093    my ($self, $c, $reqspec, @args) = @_;
1094
1095    my @message;
1096    $reqspec->{src} = 0;
1097
1098    @args = @{ $c->forward('_getopt', [
1099        {
1100            'd=s' => \$reqspec->{distribution},
1101            'v=s' => \$reqspec->{release},
1102            'r=s' => \$reqspec->{release},
1103            'a=s' => \$reqspec->{arch},
1104            's'   => \$reqspec->{src},
1105        }, @args ]) };
1106    if ($c->stash->{getopt_error}) {
1107        return $c->stash->{xmlrpc};
1108    }
1109
1110    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
1111        return $c->stash->{xmlrpc} = {
1112            message => [ "I don't have such distribution in "
1113                    .$c->forward('_fmt_question', [$reqspec])],
1114        };
1115    }
1116
1117    my $rpmlist = $c->forward('/search/rpm/byfile', [ $reqspec, $args[0] ]);
1118    if (!@{ $rpmlist }) {
1119        return $c->stash->{xmlrpc} = {
1120            message => [ "Sorry, no file $args[0] found in "
1121                    .$c->forward('_fmt_question', [$reqspec])],
1122        }
1123    } elsif (@{ $rpmlist } > 20) {
1124        foreach (@{ $rpmlist }) {
1125            my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
1126            push @message, $info->{name} . ' // ' .
1127                $c->forward('_fmt_location', [ $reqspec, $_ ]);
1128        }
1129        return $c->stash->{xmlrpc} = {
1130            message => ["find in "
1131                    .$c->forward('_fmt_question', [$reqspec])
1132                    ." :",
1133                    @message],
1134        }
1135    } else {
1136        my %list;
1137        foreach (@{ $rpmlist }) {
1138            my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
1139            $list{$info->{name}} = 1;
1140        }
1141        return $c->stash->{xmlrpc} = {
1142            message => ["find in "
1143                    .$c->forward('_fmt_question', [$reqspec])
1144                    ." : ".join(', ', sort keys %list) ],
1145        };
1146    }
1147}
1148
1149=head2 what [-d distrib] [-r release] [-a arch] [-s] p|r|c|o|e|s DEP [SENSE [EVR]]
1150
1151Search rpm matching having matching dependencies (provides, requires, conflicts,
1152obsoletes, enhanced or suggests)
1153
1154=cut
1155
1156sub what : XMLRPC {
1157    my ($self, $c, $reqspec, @args) = @_;
1158       
1159    @args = @{ $c->forward('_getopt', [
1160        {
1161            'd=s' => \$reqspec->{distribution},
1162            'v=s' => \$reqspec->{release},
1163            'r=s' => \$reqspec->{release},
1164            'a=s' => \$reqspec->{arch},
1165            's'   => \$reqspec->{src},
1166        }, @args ]) };
1167    if ($c->stash->{getopt_error}) {
1168        return $c->stash->{xmlrpc};
1169    }
1170
1171    my ($type, $depname, $sense, $evr) = @args;
1172
1173    my $deptype = uc(substr($type, 0, 1));
1174    my $rpmlist = $c->forward('/search/rpm/bydep',
1175        [ $reqspec, $deptype, $depname, $sense, $evr ]);
1176
1177    if (@{ $rpmlist } < 20) {
1178        my @name;
1179        foreach (@{ $rpmlist }) {
1180            my $info = $c->forward('/rpms/basicinfo', [ $_ ]);
1181            push @name, $info->{name} . '-' . $info->{evr};
1182        }
1183        return $c->stash->{xmlrpc} = {
1184            message => [
1185                "Package matching $depname" . ($evr ? " $sense $evr" : '') .
1186                " in "
1187                .$c->forward('_fmt_question', [$reqspec])
1188                .':', 
1189                join(' ', @name),
1190            ],
1191        }
1192    } else {
1193        return $c->stash->{xmlrpc} = {
1194            message => [ 'Too many results in ' 
1195                    .$c->forward('_fmt_question', [$reqspec])],
1196        };
1197    }
1198
1199}
1200
1201=head2 maint [-d distrib] [-r release] [-a arch] [-s] RPMNAME
1202
1203Show the maintainers for the rpm named C<RPMNAME>.
1204
1205=cut
1206
1207sub maint : XMLRPC {
1208    my ($self, $c, $reqspec, @args) = @_;
1209    $reqspec->{src} = 0;
1210    my @message;
1211    @args = @{ $c->forward('_getopt', [
1212        {
1213            'd=s' => \$reqspec->{distribution},
1214            'v=s' => \$reqspec->{release},
1215            'r=s' => \$reqspec->{release},
1216            'a=s' => \$reqspec->{arch},
1217            's'   => \$reqspec->{src},
1218        }, @args ]) };
1219    if ($c->stash->{getopt_error}) {
1220        return $c->stash->{xmlrpc};
1221    }
1222
1223    if (!$c->forward('/distrib/exists', [ $reqspec ])) {
1224        return $c->stash->{xmlrpc} = {
1225            message => [ "I don't have such distribution : " 
1226                    .$c->forward('_fmt_question', [$reqspec])],
1227        };
1228    }
1229    my $rpmlist = $c->forward('/search/rpm/byname', [ $reqspec, $args[0] ]);
1230    if (!@{ $rpmlist }) {
1231        my $else = $c->forward('_find_rpm_elsewhere', [ $reqspec, $args[0] ]);
1232        if ($else) {
1233            return $c->stash->{xmlrpc} = {
1234                message => [ 
1235                    "There is no rpm named `$args[0]' in "
1236                    .$c->forward('_fmt_question', [$reqspec])
1237                    .", but the word matches in " . $else
1238                ],
1239            }
1240        } else {
1241            return $c->stash->{xmlrpc} = {
1242                message => [ "The rpm named `$args[0]' has not been found in "
1243                    .$c->forward('_fmt_question', [$reqspec])],
1244            }
1245        }
1246    }
1247    my %maint;
1248    foreach (@{ $rpmlist }) {
1249        my $res = $c->forward('/rpms/maintainers', [ $_ ]);
1250        foreach (@$res) {
1251            my $m = 'For ' . $_->{vendor} . ' (' . $_->{rpm} . '): ' . $_->{owner};
1252            $maint{$m} = 1;
1253        }
1254    }
1255    return $c->stash->{xmlrpc} = {
1256        message => [ sort keys %maint ],
1257    }
1258}
1259
1260=head2 nb_rpm [-d distrib] NAME
1261
1262Show the count of rpm maintains by packager matching C<NAME>.
1263
1264=cut
1265
1266sub nb_rpm : XMLRPC {
1267    my ($self, $c, $reqspec, @args) = @_;
1268    my @message;
1269    my $dist = { distribution => $reqspec->{distribution} };
1270    @args = @{ $c->forward('_getopt', [
1271        {
1272            'd=s' => \$dist->{distribution},
1273        }, @args ]) };
1274    if ($c->stash->{getopt_error}) {
1275        return $c->stash->{xmlrpc};
1276    }
1277
1278    if (!$c->forward('/distrib/exists', [ $dist ])) {
1279        return $c->stash->{xmlrpc} = {
1280            message => [ "I don't have such distribution : "
1281                    .$c->forward('_fmt_question', [$reqspec])],
1282        };
1283    }
1284
1285    my $maints = $c->forward('/maintainers/search',
1286        [ $args[0], $dist->{distribution} ]);
1287    if (@$maints > 3) {
1288        return $c->stash->{xmlrpc} = {
1289            message => [ 
1290                scalar(@$maints) . " maintainers found matching `$args[0]' in "
1291                    .$c->forward('_fmt_question', [$reqspec])],
1292        };
1293    } elsif (! @$maints) {
1294        return $c->stash->{xmlrpc} = {
1295            message => [ "No maintainer found matching `$args[0]' in " 
1296                    .$c->forward('_fmt_question', [$reqspec])],
1297        };
1298    } else {
1299        my @messages;
1300        foreach (@$maints) {
1301            my $rpms = $c->forward('/maintainers/bymaintainer', [
1302                $_->{owner}, $dist->{distribution} ]);
1303            push(@messages, sprintf('%s (%s) maintains %d rpms',
1304                    $_->{owner},
1305                    $_->{vendor},
1306                    scalar(@$rpms),
1307                )
1308            );
1309        }
1310        return $c->stash->{xmlrpc} = {
1311            message => \@messages,
1312        };
1313    }
1314}
1315
1316=head1 AUTHOR
1317
1318Olivier Thauvin
1319
1320=head1 LICENSE
1321
1322This library is free software. You can redistribute it and/or modify
1323it under the same terms as Perl itself.
1324
1325=cut
1326
1327__PACKAGE__->meta->make_immutable;
1328
13291;
Note: See TracBrowser for help on using the repository browser.