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

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