apps/irssi/scripts/scriptassist.pl

   1 # by Stefan "tommie" Tomanek
   2 #
   3 # scriptassist.pl
   4
   5
   6 use strict;
   7
   8 use vars qw($VERSION %IRSSI);
   9 $VERSION = '2003020803';
  10 %IRSSI = (
  11     authors     => 'Stefan \'tommie\' Tomanek',
  12     contact     => 'stefan@pico.ruhr.de',
  13     name        => 'scriptassist',
  14     description => 'keeps your scripts on the cutting edge',
  15     license     => 'GPLv2',
  16     url         => 'http://irssi.org/scripts/',
  17     changed     => $VERSION,
  18     modules     => 'Data::Dumper LWP::UserAgent (GnuPG)',
  19     commands    => "scriptassist"
  20 );
  21
  22 use vars qw($forked %remote_db $have_gpg);
  23
  24 use Irssi 20020324;
  25 use Data::Dumper;
  26 use LWP::UserAgent;
  27 use POSIX;
  28
  29 # GnuPG is not always needed
  30 use vars qw($have_gpg @complist);
  31 $have_gpg = 0;
  32 eval "use GnuPG qw(:algo :trust);";
  33 $have_gpg = 1 if not ($@);
  34
  35 sub show_help() {
  36     my $help = "scriptassist $VERSION
  37 /scriptassist check
  38     Check all loaded scripts for new available versions
  39 /scriptassist update <script|all>
  40     Update the selected or all script to the newest version
  41 /scriptassist search <query>
  42     Search the script database
  43 /scriptassist info <scripts>
  44     Display information about <scripts>
  45 /scriptassist ratings <scripts>
  46     Retrieve the average ratings of the the scripts
  47 /scriptassist top <num>
  48     Retrieve the first <num> top rated scripts
  49 /scriptassist new <num>
  50     Display the newest <num> scripts
  51 /scriptassist rate <script> <stars>
  52     Rate the script with a number of stars ranging from 0-5
  53 /scriptassist contact <script>
  54     Write an email to the author of the script
  55     (Requires OpenURL)
  56 /scriptassist cpan <module>
  57     Visit CPAN to look for missing Perl modules
  58     (Requires OpenURL)
  59 /scriptassist install <script>
  60     Retrieve and load the script
  61 /scriptassist autorun <script>
  62     Toggles automatic loading of <script>
  63 ";
  64     my $text='';
  65     foreach (split(/\n/, $help)) {
  66         $_ =~ s/^\/(.*)$/%9\/$1%9/;
  67         $text .= $_."\n";
  68     }
  69     print CLIENTCRAP &draw_box("ScriptAssist", $text, "scriptassist help", 1);
  70     #theme_box("ScriptAssist", $text, "scriptassist help", 1);
  71 }
  72
  73 sub theme_box ($$$$) {
  74     my ($title, $text, $footer, $colour) = @_;
  75     Irssi::printformat(MSGLEVEL_CLIENTCRAP, 'box_header', $title);
  76     foreach (split(/\n/, $text)) {
  77         Irssi::printformat(MSGLEVEL_CLIENTCRAP, 'box_inside', $_);
  78     }
  79     Irssi::printformat(MSGLEVEL_CLIENTCRAP, 'box_footer', $footer);
  80 }
  81
  82 sub draw_box ($$$$) {
  83     my ($title, $text, $footer, $colour) = @_;
  84     my $box = '';
  85     $box .= '%R,--[%n%9%U'.$title.'%U%9%R]%n'."\n";
  86     foreach (split(/\n/, $text)) {
  87         $box .= '%R|%n '.$_."\n";
  88     }                                                                               $box .= '%R`--<%n'.$footer.'%R>->%n';
  89     $box =~ s/%.//g unless $colour;
  90     return $box;
  91 }
  92
  93 sub call_openurl ($) {
  94     my ($url) = @_;
  95     no strict "refs";
  96     # check for a loaded openurl
  97     if (defined %{ "Irssi::Script::openurl::" }) {
  98         &{ "Irssi::Script::openurl::launch_url" }($url);
  99     } else {
 100         print CLIENTCRAP "%R>>%n Please install openurl.pl";
 101     }
 102     use strict;
 103 }
 104
 105 sub bg_do ($) {
 106     my ($func) = @_;
 107     my ($rh, $wh);
 108     pipe($rh, $wh);
 109     if ($forked) {
 110         print CLIENTCRAP "%R>>%n Please wait until your earlier request has been finished.";
 111         return;
 112     }
 113     my $pid = fork();
 114     $forked = 1;
 115     if ($pid > 0) {
 116         print CLIENTCRAP "%R>>%n Please wait...";
 117         close $wh;
 118         Irssi::pidwait_add($pid);
 119         my $pipetag;
 120         my @args = ($rh, \$pipetag, $func);
 121         $pipetag = Irssi::input_add(fileno($rh), INPUT_READ, \&pipe_input, \@args);
 122     } else {
 123         eval {
 124             my @items = split(/ /, $func);
 125             my %result;
 126             my $ts1 = $remote_db{timestamp};
 127             my $xml = get_scripts();
 128             my $ts2 = $remote_db{timestamp};
 129             if (not($ts1 eq $ts2) && Irssi::settings_get_bool('scriptassist_cache_sources')) {
 130                 $result{db} = $remote_db{db};
 131                 $result{timestamp} = $remote_db{timestamp};
 132             }
 133             if ($items[0] eq 'check') {
 134                 $result{data}{check} = check_scripts($xml);
 135             } elsif ($items[0] eq 'update') {
 136                 shift(@items);
 137                 $result{data}{update} = update_scripts(\@items, $xml);
 138             } elsif ($items[0] eq 'search') {
 139                 shift(@items);
 140                 #$result{data}{search}{-foo} = 0;
 141                 foreach (@items) {
 142                     $result{data}{search}{$_} = search_scripts($_, $xml);
 143                 }
 144             } elsif ($items[0] eq 'install') {
 145                 shift(@items);
 146                 $result{data}{install} = install_scripts(\@items, $xml);
 147             } elsif ($items[0] eq 'debug') {
 148                 shift(@items);
 149                 $result{data}{debug} = debug_scripts(\@items);
 150             } elsif ($items[0] eq 'ratings') {
 151                 shift(@items);
 152                 @items = @{ loaded_scripts() } if $items[0] eq "all";
 153                 #$result{data}{rating}{-foo} = 1;
 154                 my %ratings = %{ get_ratings(\@items, '') };
 155                 foreach (keys %ratings) {
 156                     $result{data}{rating}{$_}{rating} = $ratings{$_}->[0];
 157                     $result{data}{rating}{$_}{votes} = $ratings{$_}->[1];
 158                 }
 159             } elsif ($items[0] eq 'rate') {
 160                 #$result{data}{rate}{-foo} = 1;
 161                 $result{data}{rate}{$items[1]} = rate_script($items[1], $items[2]);
 162             } elsif ($items[0] eq 'info') {
 163                 shift(@items);
 164                 $result{data}{info} = script_info(\@items);
 165             } elsif ($items[0] eq 'echo') {
 166                 $result{data}{echo} = 1;
 167             } elsif ($items[0] eq 'top') {
 168                 my %ratings = %{ get_ratings([], $items[1]) };
 169                 foreach (keys %ratings) {
 170                     $result{data}{rating}{$_}{rating} = $ratings{$_}->[0];
 171                     $result{data}{rating}{$_}{votes} = $ratings{$_}->[1];
 172                 }
 173             } elsif ($items[0] eq 'new') {
 174                 my $new = get_new($items[1]);
 175                 $result{data}{new} = $new;
 176             } elsif ($items[0] eq 'unknown') {
 177                 my $cmd = $items[1];
 178                 $result{data}{unknown}{$cmd} = get_unknown($cmd, $xml);
 179             }
 180             my $dumper = Data::Dumper->new([\%result]);
 181             $dumper->Purity(1)->Deepcopy(1)->Indent(0);
 182             my $data = $dumper->Dump;
 183             print($wh $data);
 184         };
 185         close($wh);
 186         POSIX::_exit(1);
 187     }
 188 }
 189
 190 sub get_unknown ($$) {
 191     my ($cmd, $db) = @_;
 192     foreach (keys %$db) {
 193         next unless defined $db->{$_}{commands};
 194         foreach my $item (split / /, $db->{$_}{commands}) {
 195             return { $_ => $db->{$_} } if ($item =~ /^$cmd$/i);
 196         }
 197     }
 198     return undef;
 199 }
 200
 201 sub script_info ($) {
 202     my ($scripts) = @_;
 203     no strict "refs";
 204     my %result;
 205     my $xml = get_scripts();
 206     foreach (@{$scripts}) {
 207         next unless (defined $xml->{$_.".pl"} || (defined %{ 'Irssi::Script::'.$_.'::' } && defined %{ 'Irssi::Script::'.$_.'::IRSSI' }));
 208         $result{$_}{version} = get_remote_version($_, $xml);
 209         my @headers = ('authors', 'contact', 'description', 'license', 'source');
 210         foreach my $entry (@headers) {
 211             $result{$_}{$entry} = ${ 'Irssi::Script::'.$_.'::IRSSI' }{$entry};
 212             if (defined $xml->{$_.".pl"}{$entry}) {
 213                 $result{$_}{$entry} = $xml->{$_.".pl"}{$entry};
 214             }
 215         }
 216         if ($xml->{$_.".pl"}{signature_available}) {
 217             $result{$_}{signature_available} = 1;
 218         }
 219         if (defined $xml->{$_.".pl"}{modules}) {
 220             my $modules = $xml->{$_.".pl"}{modules};
 221             #$result{$_}{modules}{-foo} = 1;
 222             foreach my $mod (split(/ /, $modules)) {
 223                 my $opt = ($mod =~ /\((.*)\)/)? 1 : 0;
 224                 $mod = $1 if $1;
 225                 $result{$_}{modules}{$mod}{optional} = $opt;
 226                 $result{$_}{modules}{$mod}{installed} = module_exist($mod);
 227             }
 228         } elsif (defined ${ 'Irssi::Script::'.$_.'::IRSSI' }{modules}) {
 229             my $modules = ${ 'Irssi::Script::'.$_.'::IRSSI' }{modules};
 230             foreach my $mod (split(/ /, $modules)) {
 231                 my $opt = ($mod =~ /\((.*)\)/)? 1 : 0;
 232                 $mod = $1 if $1;
 233                 $result{$_}{modules}{$mod}{optional} = $opt;
 234                 $result{$_}{modules}{$mod}{installed} = module_exist($mod);
 235             }
 236         }
 237         if (defined $xml->{$_.".pl"}{depends}) {
 238             my $depends = $xml->{$_.".pl"}{depends};
 239             foreach my $dep (split(/ /, $depends)) {
 240                 $result{$_}{depends}{$dep}{installed} = 1; #(defined ${ 'Irssi::Script::'.$dep });
 241             }
 242         }
 243     }
 244     return \%result;
 245 }
 246
 247 sub rate_script ($$) {
 248     my ($script, $stars) = @_;
 249     my $ua = LWP::UserAgent->new(env_proxy=>1, keep_alive=>1, timeout=>30);
 250     $ua->agent('ScriptAssist/'.$VERSION);
 251     my $request = HTTP::Request->new('GET', 'http://ratings.irssi.de/irssirate.pl?&stars='.$stars.'&mode=rate&script='.$script);
 252     my $response = $ua->request($request);
 253     unless ($response->is_success() && $response->content() =~ /You already rated this script/) {
 254         return 1;
 255     } else {
 256         return 0;
 257     }
 258 }
 259
 260 sub get_ratings ($$) {
 261     my ($scripts, $limit) = @_;
 262     my $ua = LWP::UserAgent->new(env_proxy=>1, keep_alive=>1, timeout=>30);
 263     $ua->agent('ScriptAssist/'.$VERSION);
 264     my $script = join(',', @{$scripts});
 265     my $request = HTTP::Request->new('GET', 'http://ratings.irssi.de/irssirate.pl?script='.$script.'&sort=rating&limit='.$limit);
 266     my $response = $ua->request($request);
 267     my %result;
 268     if ($response->is_success()) {
 269         foreach (split /\n/, $response->content()) {
 270             if (/<tr><td><a href=".*?">(.*?)<\/a>/) {
 271                 my $entry = $1;
 272                 if (/"><\/td><td>([0-9.]+)<\/td><td>(.*?)<\/td><td>/) {
 273                     $result{$entry} = [$1, $2];
 274                 }
 275             }
 276         }
 277     }
 278     return \%result;
 279 }
 280
 281 sub get_new ($) {
 282     my ($num) = @_;
 283     my $result;
 284     my $xml = get_scripts();
 285     foreach (sort {$xml->{$b}{last_modified} cmp $xml->{$a}{last_modified}} keys %$xml) {
 286         my %entry = %{ $xml->{$_} };
 287         $result->{$_} = \%entry;
 288         $num--;
 289         last unless $num;
 290     }
 291     return $result;
 292 }
 293 sub module_exist ($) {
 294     my ($module) = @_;
 295     $module =~ s/::/\//g;
 296     foreach (@INC) {
 297         return 1 if (-e $_."/".$module.".pm");
 298     }
 299     return 0;
 300 }
 301
 302 sub debug_scripts ($) {
 303     my ($scripts) = @_;
 304     my %result;
 305     foreach (@{$scripts}) {
 306         my $xml = get_scripts();
 307         if (defined $xml->{$_.".pl"}{modules}) {
 308             my $modules = $xml->{$_.".pl"}{modules};
 309             foreach my $mod (split(/ /, $modules)) {
 310                 my $opt = ($mod =~ /\((.*)\)/)? 1 : 0;
 311                 $mod = $1 if $1;
 312                 $result{$_}{$mod}{optional} = $opt;
 313                 $result{$_}{$mod}{installed} = module_exist($mod);
 314             }
 315         }
 316     }
 317     return(\%result);
 318 }
 319
 320 sub install_scripts ($$) {
 321     my ($scripts, $xml) = @_;
 322     my %success;
 323     #$success{-foo} = 1;
 324     my $dir = Irssi::get_irssi_dir()."/scripts/";
 325     foreach (@{$scripts}) {
 326         if (get_local_version($_) && (-e $dir.$_.".pl")) {
 327             $success{$_}{installed} = -2;
 328         } else {
 329             $success{$_} = download_script($_, $xml);
 330         }
 331     }
 332     return \%success;
 333 }
 334
 335 sub update_scripts ($$) {
 336     my ($list, $database) = @_;
 337     $list = loaded_scripts() if ($list->[0] eq "all" || scalar(@$list) == 0);
 338     my %status;
 339     #$status{-foo} = 1;
 340     foreach (@{$list}) {
 341         my $local = get_local_version($_);
 342         my $remote = get_remote_version($_, $database);
 343         next if $local eq '' || $remote eq '';
 344         if (compare_versions($local, $remote) eq "older") {
 345             $status{$_} = download_script($_, $database);
 346         } else {
 347             $status{$_}{installed} = -2;
 348         }
 349         $status{$_}{remote} = $remote;
 350         $status{$_}{local} = $local;
 351     }
 352     return \%status;
 353 }
 354
 355 sub search_scripts ($$) {
 356     my ($query, $database) = @_;
 357     my %result;
 358     #$result{-foo} = " ";
 359     foreach (sort keys %{$database}) {
 360         my %entry = %{$database->{$_}};
 361         my $string = $_." ";
 362         $string .= $entry{description} if defined $entry{description};
 363         if ($string =~ /$query/i) {
 364             my $name = $_;
 365             $name =~ s/\.pl$//;
 366             if (defined $entry{description}) {
 367                 $result{$name}{desc} = $entry{description};
 368             } else {
 369                 $result{$name}{desc} = "";
 370             }
 371             if (defined $entry{authors}) {
 372                 $result{$name}{authors} = $entry{authors};
 373             } else {
 374                 $result{$name}{authors} = "";
 375             }
 376             if (get_local_version($name)) {
 377                 $result{$name}{installed} = 1;
 378             } else {
 379                 $result{$name}{installed} = 0;
 380             }
 381         }
 382     }
 383     return \%result;
 384 }
 385
 386 sub pipe_input {
 387     my ($rh, $pipetag) = @{$_[0]};
 388     my @lines = <$rh>;
 389     close($rh);
 390     Irssi::input_remove($$pipetag);
 391     $forked = 0;
 392     my $text = join("", @lines);
 393     unless ($text) {
 394         print CLIENTCRAP "%R<<%n Something weird happend";
 395         return();
 396     }
 397     no strict "vars";
 398     my $incoming = eval("$text");
 399     if ($incoming->{db} && $incoming->{timestamp}) {
 400         $remote_db{db} = $incoming->{db};
 401         $remote_db{timestamp} = $incoming->{timestamp};
 402     }
 403     unless (defined $incoming->{data}) {
 404         print CLIENTCRAP "%R<<%n Something weird happend";
 405         return;
 406     }
 407     my %result = %{ $incoming->{data} };
 408     @complist = ();
 409     if (defined $result{new}) {
 410         print_new($result{new});
 411         push @complist, $_ foreach keys %{ $result{new} };
 412     }
 413     if (defined $result{check}) {
 414         print_check(%{$result{check}});
 415         push @complist, $_ foreach keys %{ $result{check} };
 416     }
 417     if (defined $result{update}) {
 418         print_update(%{ $result{update} });
 419         push @complist, $_ foreach keys %{ $result{update} };
 420     }
 421     if (defined $result{search}) {
 422         foreach (keys %{$result{search}}) {
 423             print_search($_, %{$result{search}{$_}});
 424             push @complist, keys(%{$result{search}{$_}});
 425         }
 426     }
 427     if (defined $result{install}) {
 428         print_install(%{ $result{install} });
 429         push @complist, $_ foreach keys %{ $result{install} };
 430     }
 431     if (defined $result{debug}) {
 432         print_debug(%{ $result{debug} });
 433     }
 434     if (defined $result{rating}) {
 435         print_ratings(%{ $result{rating} });
 436         push @complist, $_ foreach keys %{ $result{rating} };
 437     }
 438     if (defined $result{rate}) {
 439         print_rate(%{ $result{rate} });
 440     }
 441     if (defined $result{info}) {
 442         print_info(%{ $result{info} });
 443     }
 444     if (defined $result{echo}) {
 445         Irssi::print "ECHO";
 446     }
 447     if ($result{unknown}) {
 448         print_unknown($result{unknown});
 449     }
 450
 451 }
 452
 453 sub print_unknown ($) {
 454     my ($data) = @_;
 455     foreach my $cmd (keys %$data) {
 456         print CLIENTCRAP "%R<<%n No script provides '/$cmd'" unless $data->{$cmd};
 457         foreach (keys %{ $data->{$cmd} }) {
 458             my $text .= "The command '/".$cmd."' is provided by the script '".$data->{$cmd}{$_}{name}."'.\n";
 459             $text .= "This script is currently not installed on your system.\n";
 460             $text .= "If you want to install the script, enter\n";
 461             my ($name) = /(.*?)\.pl$/;
 462             $text .= "  %U/script install ".$name."%U ";
 463             my $output = draw_box("ScriptAssist", $text, "'".$_."' missing", 1);
 464             print CLIENTCRAP $output;
 465         }
 466     }
 467 }
 468
 469 sub check_autorun ($) {
 470     my ($script) = @_;
 471     my $dir = Irssi::get_irssi_dir()."/scripts/";
 472     if (-e $dir."/autorun/".$script.".pl") {
 473         if (readlink($dir."/autorun/".$script.".pl") eq "../".$script.".pl") {
 474             return 1;
 475         }
 476     }
 477     return 0;
 478 }
 479
 480 sub array2table {
 481     my (@array) = @_;
 482     my @width;
 483     foreach my $line (@array) {
 484         for (0..scalar(@$line)-1) {
 485             my $l = $line->[$_];
 486             $l =~ s/%[^%]//g;
 487             $l =~ s/%%/%/g;
 488             $width[$_] = length($l) if $width[$_]<length($l);
 489         }
 490     }
 491     my $text;
 492     foreach my $line (@array) {
 493         for (0..scalar(@$line)-1) {
 494             my $l = $line->[$_];
 495             $text .= $line->[$_];
 496             $l =~ s/%[^%]//g;
 497             $l =~ s/%%/%/g;
 498             $text .= " "x($width[$_]-length($l)+1) unless ($_ == scalar(@$line)-1);
 499         }
 500         $text .= "\n";
 501     }
 502     return $text;
 503 }
 504
 505
 506 sub print_info (%) {
 507     my (%data) = @_;
 508     my $line;
 509     foreach my $script (sort keys(%data)) {
 510         my ($local, $autorun);
 511         if (get_local_version($script)) {
 512             $line .= "%go%n ";
 513             $local = get_local_version($script);
 514         } else {
 515             $line .= "%ro%n ";
 516             $local = undef;
 517         }
 518         if (defined $local || check_autorun($script)) {
 519             $autorun = "no";
 520             $autorun = "yes" if check_autorun($script);
 521         } else {
 522             $autorun = undef;
 523         }
 524         $line .= "%9".$script."%9\n";
 525         $line .= "  Version    : ".$data{$script}{version}."\n";
 526         $line .= "  Source     : ".$data{$script}{source}."\n";
 527         $line .= "  Installed  : ".$local."\n" if defined $local;
 528         $line .= "  Autorun    : ".$autorun."\n" if defined $autorun;
 529         $line .= "  Authors    : ".$data{$script}{authors};
 530         $line .= " %Go-m signed%n" if $data{$script}{signature_available};
 531         $line .= "\n";
 532         $line .= "  Contact    : ".$data{$script}{contact}."\n";
 533         $line .= "  Description: ".$data{$script}{description}."\n";
 534         $line .= "\n" if $data{$script}{modules};
 535         $line .= "  Needed Perl modules:\n" if $data{$script}{modules};
 536
 537         foreach (sort keys %{$data{$script}{modules}}) {
 538             if ( $data{$script}{modules}{$_}{installed} == 1 ) {
 539                 $line .= "  %g->%n ".$_." (found)";
 540             } else {
 541                 $line .= "  %r->%n ".$_." (not found)";
 542             }
 543             $line .= " <optional>" if $data{$script}{modules}{$_}{optional};
 544             $line .= "\n";
 545         }
 546         #$line .= "  Needed Irssi scripts:\n";
 547         $line .= "  Needed Irssi Scripts:\n" if $data{$script}{depends};
 548         foreach (sort keys %{$data{$script}{depends}}) {
 549             if ( $data{$script}{depends}{$_}{installed} == 1 ) {
 550                 $line .= "  %g->%n ".$_." (loaded)";
 551             } else {
 552                 $line .= "  %r->%n ".$_." (not loaded)";
 553             }
 554             #$line .= " <optional>" if $data{$script}{depends}{$_}{optional};
 555             $line .= "\n";
 556         }
 557     }
 558     print CLIENTCRAP draw_box('ScriptAssist', $line, 'info', 1) ;
 559 }
 560
 561 sub print_rate (%) {
 562     my (%data) = @_;
 563     my $line;
 564     foreach my $script (sort keys(%data)) {
 565         if ($data{$script}) {
 566             $line .= "%go%n %9".$script."%9 has been rated";
 567         } else {
 568             $line .= "%ro%n %9".$script."%9 : Already rated this script";
 569         }
 570     }
 571     print CLIENTCRAP draw_box('ScriptAssist', $line, 'rating', 1) ;
 572 }
 573
 574 sub print_ratings (%) {
 575     my (%data) = @_;
 576     my @table;
 577     foreach my $script (sort {$data{$b}{rating}<=>$data{$a}{rating}} keys(%data)) {
 578         my @line;
 579         if (get_local_version($script)) {
 580             push @line, "%go%n";
 581         } else {
 582             push @line, "%yo%n";
 583         }
 584         push @line, "%9".$script."%9";
 585         push @line, $data{$script}{rating};
 586         push @line, "[".$data{$script}{votes}." votes]";
 587         push @table, \@line;
 588     }
 589     print CLIENTCRAP draw_box('ScriptAssist', array2table(@table), 'ratings', 1) ;
 590 }
 591
 592 sub print_new ($) {
 593     my ($list) = @_;
 594     my @table;
 595     foreach (sort {$list->{$b}{last_modified} cmp $list->{$a}{last_modified}} keys %$list) {
 596         my @line;
 597         my ($name) = /^(.*?)\.pl$/;
 598         if (get_local_version($name)) {
 599             push @line, "%go%n";
 600         } else {
 601             push @line, "%yo%n";
 602         }
 603         push @line, "%9".$name."%9";
 604         push @line, $list->{$_}{last_modified};
 605         push @table, \@line;
 606     }
 607     print CLIENTCRAP draw_box('ScriptAssist', array2table(@table), 'new scripts', 1) ;
 608 }
 609
 610 sub print_debug (%) {
 611     my (%data) = @_;
 612     my $line;
 613     foreach my $script (sort keys %data) {
 614         $line .= "%ro%n %9".$script."%9 failed to load\n";
 615         $line .= "  Make sure you have the following perl modules installed:\n";
 616         foreach (sort keys %{$data{$script}}) {
 617             if ( $data{$script}{$_}{installed} == 1 ) {
 618                 $line .= "  %g->%n ".$_." (found)";
 619             } else {
 620                 $line .= "  %r->%n ".$_." (not found)\n";
 621                 $line .= "     [This module is optional]\n" if $data{$script}{$_}{optional};
 622                 $line .= "     [Try /scriptassist cpan ".$_."]";
 623             }
 624             $line .= "\n";
 625         }
 626         print CLIENTCRAP draw_box('ScriptAssist', $line, 'debug', 1) ;
 627     }
 628 }
 629
 630 sub load_script ($) {
 631     my ($script) = @_;
 632     Irssi::command('script load '.$script);
 633 }
 634
 635 sub print_install (%) {
 636     my (%data) = @_;
 637     my $text;
 638     my ($crashed, @installed);
 639     foreach my $script (sort keys %data) {
 640         my $line;
 641         if ($data{$script}{installed} == 1) {
 642             my $hacked;
 643             if ($have_gpg && Irssi::settings_get_bool('scriptassist_use_gpg')) {
 644                 if ($data{$script}{signed} >= 0) {
 645                     load_script($script) unless (lc($script) eq lc($IRSSI{name}));
 646                 } else {
 647                     $hacked = 1;
 648                 }
 649             } else {
 650                 load_script($script) unless (lc($script) eq lc($IRSSI{name}));
 651             }
 652             if (get_local_version($script) && not lc($script) eq lc($IRSSI{name})) {
 653                 $line .= "%go%n %9".$script."%9 installed\n";
 654                 push @installed, $script;
 655             } elsif (lc($script) eq lc($IRSSI{name})) {
 656                 $line .= "%yo%n %9".$script."%9 installed, please reload manually\n";
 657             } else {
 658                 $line .= "%Ro%n %9".$script."%9 fetched, but unable to load\n";
 659                 $crashed .= $script." " unless $hacked;
 660             }
 661             if ($have_gpg && Irssi::settings_get_bool('scriptassist_use_gpg')) {
 662                 foreach (split /\n/, check_sig($data{$script})) {
 663                     $line .= "  ".$_."\n";
 664                 }
 665             }
 666         } elsif ($data{$script}{installed} == -2) {
 667             $line .= "%ro%n %9".$script."%9 already loaded, please try \"update\"\n";
 668         } elsif ($data{$script}{installed} <= 0) {
 669             $line .= "%ro%n %9".$script."%9 not installed\n";
 670             foreach (split /\n/, check_sig($data{$script})) {
 671                 $line .= "  ".$_."\n";
 672             }
 673         } else {
 674             $line .= "%Ro%n %9".$script."%9 not found on server\n";
 675         }
 676         $text .= $line;
 677     }
 678     # Inspect crashed scripts
 679     bg_do("debug ".$crashed) if $crashed;
 680     print CLIENTCRAP draw_box('ScriptAssist', $text, 'install', 1);
 681     list_sbitems(\@installed);
 682 }
 683
 684 sub list_sbitems ($) {
 685     my ($scripts) = @_;
 686     my $text;
 687     foreach (@$scripts) {
 688         no strict 'refs';
 689         next unless defined %{ "Irssi::Script::${_}::" };
 690         next unless defined %{ "Irssi::Script::${_}::IRSSI" };
 691         my %header = %{ "Irssi::Script::${_}::IRSSI" };
 692         next unless $header{sbitems};
 693         $text .= '%9"'.$_.'"%9 provides the following statusbar item(s):'."\n";
 694         $text .= '  ->'.$_."\n" foreach (split / /, $header{sbitems});
 695     }
 696     return unless $text;
 697     $text .= "\n";
 698     $text .= "Enter '/statusbar window add <item>' to add an item.";
 699     print CLIENTCRAP draw_box('ScriptAssist', $text, 'sbitems', 1);
 700 }
 701
 702 sub check_sig ($) {
 703     my ($sig) = @_;
 704     my $line;
 705     my %trust = ( -1 => 'undefined',
 706                    0 => 'never',
 707                    1 => 'marginal',
 708                    2 => 'fully',
 709                    3 => 'ultimate'
 710                  );
 711     if ($sig->{signed} == 1) {
 712         $line .= "Signature found from ".$sig->{sig}{user}."\n";
 713         $line .= "Timestamp  : ".$sig->{sig}{date}."\n";
 714         $line .= "Fingerprint: ".$sig->{sig}{fingerprint}."\n";
 715         $line .= "KeyID      : ".$sig->{sig}{keyid}."\n";
 716         $line .= "Trust      : ".$trust{$sig->{sig}{trust}}."\n";
 717     } elsif ($sig->{signed} == -1) {
 718         $line .= "%1Warning, unable to verify signature%n\n";
 719     } elsif ($sig->{signed} == 0) {
 720         $line .= "%1No signature found%n\n" unless Irssi::settings_get_bool('scriptassist_install_unsigned_scripts');
 721     }
 722     return $line;
 723 }
 724
 725 sub print_search ($%) {
 726     my ($query, %data) = @_;
 727     my $text;
 728     foreach (sort keys %data) {
 729         my $line;
 730         $line .= "%go%n" if $data{$_}{installed};
 731         $line .= "%yo%n" if not $data{$_}{installed};
 732         $line .= " %9".$_."%9 ";
 733         $line .= $data{$_}{desc};
 734         $line =~ s/($query)/%U$1%U/gi;
 735         $line .= ' ('.$data{$_}{authors}.')';
 736         $text .= $line." \n";
 737     }
 738     print CLIENTCRAP draw_box('ScriptAssist', $text, 'search: '.$query, 1) ;
 739 }
 740
 741 sub print_update (%) {
 742     my (%data) = @_;
 743     my $text;
 744     my @table;
 745     my $verbose = Irssi::settings_get_bool('scriptassist_update_verbose');
 746     foreach (sort keys %data) {
 747         my $signed = 0;
 748         if ($data{$_}{installed} == 1) {
 749             my $local = $data{$_}{local};
 750             my $remote = $data{$_}{remote};
 751             push @table, ['%yo%n', '%9'.$_.'%9', 'upgraded ('.$local.'->'.$remote.')'];
 752             foreach (split /\n/, check_sig($data{$_})) {
 753                 push @table, ['', '', $_];
 754             }
 755             if (lc($_) eq lc($IRSSI{name})) {
 756                 push @table, ['', '', "%R%9Please reload manually%9%n"];
 757             } else {
 758                 load_script($_);
 759             }
 760         } elsif ($data{$_}{installed} == 0 || $data{$_}{installed} == -1) {
 761             push @table, ['%yo%n', '%9'.$_.'%9', 'not upgraded'];
 762             foreach (split /\n/, check_sig($data{$_})) {
 763                 push @table, ['', '', $_];
 764             }
 765         } elsif ($data{$_}{installed} == -2 && $verbose) {
 766             my $local = $data{$_}{local};
 767             push @table, ['%go%n', '%9'.$_.'%9', 'already at the latest version ('.$local.')'];
 768         }
 769     }
 770     $text = array2table(@table);
 771     print CLIENTCRAP draw_box('ScriptAssist', $text, 'update', 1) ;
 772 }
 773
 774 sub contact_author ($) {
 775     my ($script) = @_;
 776     no strict 'refs';
 777     return unless defined %{ "Irssi::Script::${script}::" };
 778     my %header = %{ "Irssi::Script::${script}::IRSSI" };
 779     if (defined $header{contact}) {
 780         my @ads = split(/ |,/, $header{contact});
 781         my $address = $ads[0];
 782         $address .= '?subject='.$script;
 783         $address .= '_'.get_local_version($script) if defined get_local_version($script);
 784         call_openurl($address);
 785     }
 786 }
 787
 788 sub get_scripts {
 789     my $ua = LWP::UserAgent->new(env_proxy=>1, keep_alive=>1, timeout=>30);
 790     $ua->agent('ScriptAssist/'.$VERSION);
 791     $ua->env_proxy();
 792     my @mirrors = split(/ /, Irssi::settings_get_str('scriptassist_script_sources'));
 793     my %sites_db;
 794     my $fetched = 0;
 795     my @sources;
 796     foreach my $site (@mirrors) {
 797         my $request = HTTP::Request->new('GET', $site);
 798         if ($remote_db{timestamp}) {
 799             $request->if_modified_since($remote_db{timestamp});
 800         }
 801         my $response = $ua->request($request);
 802         next unless $response->is_success;
 803         $fetched = 1;
 804         my $data = $response->content();
 805         my ($src, $type);
 806         if ($site =~ /(.*\/).+\.(.+)/) {
 807             $src = $1;
 808             $type = $2;
 809         }
 810         push @sources, $src;
 811         #my @header = ('name', 'contact', 'authors', 'description', 'version', 'modules', 'last_modified');
 812         if ($type eq 'dmp') {
 813             no strict 'vars';
 814             my $new_db = eval "$data";
 815             foreach (keys %$new_db) {
 816                 if (defined $sites_db{script}{$_}) {
 817                     my $old = $sites_db{$_}{version};
 818                     my $new = $new_db->{$_}{version};
 819                     next if (compare_versions($old, $new) eq 'newer');
 820                 }
 821                 #foreach my $key (@header) {
 822                 foreach my $key (keys %{ $new_db->{$_} }) {
 823                     next unless defined $new_db->{$_}{$key};
 824                     $sites_db{$_}{$key} = $new_db->{$_}{$key};
 825                 }
 826                 $sites_db{$_}{source} = $src;
 827             }
 828         } else {
 829             ## FIXME Panic?!
 830         }
 831
 832     }
 833     if ($fetched) {
 834         # Clean database
 835         foreach (keys %{$remote_db{db}}) {
 836             foreach my $site (@sources) {
 837                 if ($remote_db{db}{$_}{source} eq $site) {
 838                     delete $remote_db{db}{$_};
 839                     last;
 840                 }
 841             }
 842         }
 843         $remote_db{db}{$_} = $sites_db{$_} foreach (keys %sites_db);
 844         $remote_db{timestamp} = time();
 845     }
 846     return $remote_db{db};
 847 }
 848
 849 sub get_remote_version ($$) {
 850     my ($script, $database) = @_;
 851     return $database->{$script.".pl"}{version};
 852 }
 853
 854 sub get_local_version ($) {
 855     my ($script) = @_;
 856     no strict 'refs';
 857     return unless defined %{ "Irssi::Script::${script}::" };
 858     my $version = ${ "Irssi::Script::${script}::VERSION" };
 859     return $version;
 860 }
 861
 862 sub compare_versions ($$) {
 863     my ($ver1, $ver2) = @_;
 864     my @ver1 = split /\./, $ver1;
 865     my @ver2 = split /\./, $ver2;
 866     #if (scalar(@ver2) != scalar(@ver1)) {
 867     #    return 0;
 868     #}
 869     my $cmp = 0;
 870     ### Special thanks to Clemens Heidinger
 871     $cmp ||= $ver1[$_] <=> $ver2[$_] || $ver1[$_] cmp $ver2[$_] for 0..scalar(@ver2);
 872     return 'newer' if $cmp == 1;
 873     return 'older' if $cmp == -1;
 874     return 'equal';
 875 }
 876
 877 sub loaded_scripts {
 878     no strict 'refs';
 879     my @modules;
 880     foreach (sort grep(s/::$//, keys %Irssi::Script::)) {
 881         #my $name    = ${ "Irssi::Script::${_}::IRSSI" }{name};
 882         #my $version = ${ "Irssi::Script::${_}::VERSION" };
 883         push @modules, $_;# if $name && $version;
 884     }
 885     return \@modules;
 886
 887 }
 888
 889 sub check_scripts {
 890     my ($data) = @_;
 891     my %versions;
 892     #$versions{-foo} = 1;
 893     foreach (@{loaded_scripts()}) {
 894         my $remote = get_remote_version($_, $data);
 895         my $local =  get_local_version($_);
 896         my $state;
 897         if ($local && $remote) {
 898             $state = compare_versions($local, $remote);
 899         } elsif ($local) {
 900             $state = 'noversion';
 901             $remote = '/';
 902         } else {
 903             $state = 'noheader';
 904             $local = '/';
 905             $remote = '/';
 906         }
 907         if ($state) {
 908             $versions{$_}{state} = $state;
 909             $versions{$_}{remote} = $remote;
 910             $versions{$_}{local} = $local;
 911         }
 912     }
 913     return \%versions;
 914 }
 915
 916 sub download_script ($$) {
 917     my ($script, $xml) = @_;
 918     my %result;
 919     my $site = $xml->{$script.".pl"}{source};
 920     $result{installed} = 0;
 921     $result{signed} = 0;
 922     my $dir = Irssi::get_irssi_dir();
 923     my $ua = LWP::UserAgent->new(env_proxy => 1,keep_alive => 1,timeout => 30);
 924     $ua->agent('ScriptAssist/'.$VERSION);
 925     my $request = HTTP::Request->new('GET', $site.'/scripts/'.$script.'.pl');
 926     my $response = $ua->request($request);
 927     if ($response->is_success()) {
 928         my $file = $response->content();
 929         mkdir $dir.'/scripts/' unless (-e $dir.'/scripts/');
 930         local *F;
 931         open(F, '>'.$dir.'/scripts/'.$script.'.pl.new');
 932         print F $file;
 933         close(F);
 934         if ($have_gpg && Irssi::settings_get_bool('scriptassist_use_gpg')) {
 935             my $ua2 = LWP::UserAgent->new(env_proxy => 1,keep_alive => 1,timeout => 30);
 936             $ua->agent('ScriptAssist/'.$VERSION);
 937             my $request2 = HTTP::Request->new('GET', $site.'/signatures/'.$script.'.pl.asc');
 938             my $response2 = $ua->request($request2);
 939             if ($response2->is_success()) {
 940                 local *S;
 941                 my $sig_dir = $dir.'/scripts/signatures/';
 942                 mkdir $sig_dir unless (-e $sig_dir);
 943                 open(S, '>'.$sig_dir.$script.'.pl.asc');
 944                 my $file2 = $response2->content();
 945                 print S $file2;
 946                 close(S);
 947                 my $sig;
 948                 foreach (1..2) {
 949                     # FIXME gpg needs two rounds to load the key
 950                     my $gpg = new GnuPG();
 951                     eval {
 952                         $sig = $gpg->verify( file => $dir.'/scripts/'.$script.'.pl.new', signature => $sig_dir.$script.'.pl.asc' );
 953                     };
 954                 }
 955                 if (defined $sig->{user}) {
 956                     $result{installed} = 1;
 957                     $result{signed} = 1;
 958                     $result{sig}{$_} = $sig->{$_} foreach (keys %{$sig});
 959                 } else {
 960                     # Signature broken?
 961                     $result{installed} = 0;
 962                     $result{signed} = -1;
 963                 }
 964             } else {
 965                 $result{signed} = 0;
 966                 $result{installed} = -1;
 967                 $result{installed} = 1 if Irssi::settings_get_bool('scriptassist_install_unsigned_scripts');
 968             }
 969         } else {
 970             $result{signed} = 0;
 971             $result{installed} = -1;
 972             $result{installed} = 1 if Irssi::settings_get_bool('scriptassist_install_unsigned_scripts');
 973         }
 974     }
 975     if ($result{installed}) {
 976         my $old_dir = "$dir/scripts/old/";
 977         mkdir $old_dir unless (-e $old_dir);
 978         rename "$dir/scripts/$script.pl", "$old_dir/$script.pl.old" if -e "$dir/scripts/$script.pl";
 979         rename "$dir/scripts/$script.pl.new", "$dir/scripts/$script.pl";
 980     }
 981     return \%result;
 982 }
 983
 984 sub print_check (%) {
 985     my (%data) = @_;
 986     my $text;
 987     my @table;
 988     foreach (sort keys %data) {
 989         my $state = $data{$_}{state};
 990         my $remote = $data{$_}{remote};
 991         my $local = $data{$_}{local};
 992         if (Irssi::settings_get_bool('scriptassist_check_verbose')) {
 993             push @table, ['%go%n', '%9'.$_.'%9', 'Up to date. ('.$local.')'] if $state eq 'equal';
 994         }
 995         push @table, ['%mo%n', '%9'.$_.'%9', "No version information available on network."] if $state eq "noversion";
 996         push @table, ['%mo%n', '%9'.$_.'%9', 'No header in script.'] if $state eq "noheader";
 997         push @table, ['%bo%n', '%9'.$_.'%9', "Your version is newer (".$local."->".$remote.")"] if $state eq "newer";
 998         push @table, ['%ro%n', '%9'.$_.'%9', "A new version is available (".$local."->".$remote.")"] if $state eq "older";;
 999     }
1000     $text = array2table(@table);
1001     print CLIENTCRAP draw_box('ScriptAssist', $text, 'check', 1) ;
1002 }
1003
1004 sub toggle_autorun ($) {
1005     my ($script) = @_;
1006     my $dir = Irssi::get_irssi_dir()."/scripts/";
1007     mkdir $dir."autorun/" unless (-e $dir."autorun/");
1008     return unless (-e $dir.$script.".pl");
1009     if (check_autorun($script)) {
1010         if (readlink($dir."/autorun/".$script.".pl") eq "../".$script.".pl") {
1011             if (unlink($dir."/autorun/".$script.".pl")) {
1012                 print CLIENTCRAP "%R>>%n Autorun of ".$script." disabled";
1013             } else {
1014                 print CLIENTCRAP "%R>>%n Unable to delete link";
1015             }
1016         } else {
1017             print CLIENTCRAP "%R>>%n ".$dir."/autorun/".$script.".pl is not a correct link";
1018         }
1019     } else {
1020         symlink("../".$script.".pl", $dir."/autorun/".$script.".pl");
1021         print CLIENTCRAP "%R>>%n Autorun of ".$script." enabled";
1022     }
1023 }
1024
1025 sub sig_script_error ($$) {
1026     my ($script, $msg) = @_;
1027     return unless Irssi::settings_get_bool('scriptassist_catch_script_errors');
1028     if ($msg =~ /Can't locate (.*?)\.pm in \@INC \(\@INC contains:(.*?) at/) {
1029         my $module = $1;
1030         $module =~ s/\//::/g;
1031         missing_module($module);
1032     }
1033 }
1034
1035 sub missing_module ($$) {
1036     my ($module) = @_;
1037     my $text;
1038     $text .= "The perl module %9".$module."%9 is missing on your system.\n";
1039     $text .= "Please ask your administrator about it.\n";
1040     $text .= "You can also check CPAN via '/scriptassist cpan ".$module."'.\n";
1041     print CLIENTCRAP &draw_box('ScriptAssist', $text, $module, 1);
1042 }
1043
1044 sub cmd_scripassist ($$$) {
1045     my ($arg, $server, $witem) = @_;
1046     my @args = split(/ /, $arg);
1047     if ($args[0] eq 'help' || $args[0] eq '-h') {
1048         show_help();
1049     } elsif ($args[0] eq 'check') {
1050         bg_do("check");
1051     } elsif ($args[0] eq 'update') {
1052         shift @args;
1053         bg_do("update ".join(' ', @args));
1054     } elsif ($args[0] eq 'search' && defined $args[1]) {
1055         shift @args;
1056         bg_do("search ".join(" ", @args));
1057     } elsif ($args[0] eq 'install' && defined $args[1]) {
1058         shift @args;
1059         bg_do("install ".join(' ', @args));
1060     } elsif ($args[0] eq 'contact' && defined $args[1]) {
1061         contact_author($args[1]);
1062     } elsif ($args[0] eq 'ratings' && defined $args[1]) {
1063         shift @args;
1064         bg_do("ratings ".join(' ', @args));
1065     } elsif ($args[0] eq 'rate' && defined $args[1] && defined $args[2]) {
1066         shift @args;
1067         bg_do("rate ".join(' ', @args)) if ($args[2] >= 0 && $args[2] < 6);
1068     } elsif ($args[0] eq 'info' && defined $args[1]) {
1069         shift @args;
1070         bg_do("info ".join(' ', @args));
1071     } elsif ($args[0] eq 'echo') {
1072         bg_do("echo");
1073     } elsif ($args[0] eq 'top') {
1074         my $number = defined $args[1] ? $args[1] : 10;
1075         bg_do("top ".$number);
1076     } elsif ($args[0] eq 'cpan' && defined $args[1]) {
1077         call_openurl('http://search.cpan.org/search?mode=module&query='.$args[1]);
1078     } elsif ($args[0] eq 'autorun' && defined $args[1]) {
1079         toggle_autorun($args[1]);
1080     } elsif ($args[0] eq 'new') {
1081         my $number = defined $args[1] ? $args[1] : 5;
1082         bg_do("new ".$number);
1083     }
1084 }
1085
1086 sub sig_command_script_load ($$$) {
1087     my ($script, $server, $witem) = @_;
1088     no strict;
1089     $script = $2 if $script =~ /(.*\/)?(.*?)\.pl$/;
1090     if (defined %{ "Irssi::Script::${script}::" }) {
1091         if (defined &{ "Irssi::Script::${script}::pre_unload" }) {
1092             print CLIENTCRAP "%R>>%n Triggering pre_unload function of $script...";
1093             &{ "Irssi::Script::${script}::pre_unload" }();
1094         }
1095     }
1096 }
1097
1098 sub sig_default_command ($$) {
1099     my ($cmd, $server) = @_;
1100     return unless Irssi::settings_get_bool("scriptassist_check_unknown_commands");
1101     bg_do('unknown '.$cmd);
1102 }
1103
1104 sub sig_complete ($$$$$) {
1105     my ($list, $window, $word, $linestart, $want_space) = @_;
1106     return unless $linestart =~ /^.script(assist)? (install|rate|ratings|update|check|contact|info|autorun)/;
1107     my @newlist;
1108     my $str = $word;
1109     foreach (@complist) {
1110         if ($_ =~ /^(\Q$str\E.*)?$/) {
1111             push @newlist, $_;
1112         }
1113     }
1114     foreach (@{loaded_scripts()}) {
1115         push @newlist, $_ if /^(\Q$str\E.*)?$/;
1116     }
1117     $want_space = 0;
1118     push @$list, $_ foreach @newlist;
1119     Irssi::signal_stop();
1120 }
1121
1122
1123 Irssi::settings_add_str($IRSSI{name}, 'scriptassist_script_sources', 'http://scripts.irssi.org/scripts.dmp');
1124 Irssi::settings_add_bool($IRSSI{name}, 'scriptassist_cache_sources', 1);
1125 Irssi::settings_add_bool($IRSSI{name}, 'scriptassist_update_verbose', 1);
1126 Irssi::settings_add_bool($IRSSI{name}, 'scriptassist_check_verbose', 1);
1127 Irssi::settings_add_bool($IRSSI{name}, 'scriptassist_catch_script_errors', 1);
1128
1129 Irssi::settings_add_bool($IRSSI{name}, 'scriptassist_install_unsigned_scripts', 1);
1130 Irssi::settings_add_bool($IRSSI{name}, 'scriptassist_use_gpg', 1);
1131 Irssi::settings_add_bool($IRSSI{name}, 'scriptassist_integrate', 1);
1132 Irssi::settings_add_bool($IRSSI{name}, 'scriptassist_check_unknown_commands', 1);
1133
1134 Irssi::signal_add_first("default command", \&sig_default_command);
1135 Irssi::signal_add_first('complete word', \&sig_complete);
1136 Irssi::signal_add_first('command script load', \&sig_command_script_load);
1137 Irssi::signal_add_first('command script unload', \&sig_command_script_load);
1138
1139 if (defined &Irssi::signal_register) {
1140     Irssi::signal_register({ 'script error' => [ 'Irssi::Script', 'string' ] });
1141     Irssi::signal_add_last('script error', \&sig_script_error);
1142 }
1143
1144 Irssi::command_bind('scriptassist', \&cmd_scripassist);
1145
1146 Irssi::theme_register(['box_header', '%R,--[%n$*%R]%n',
1147 'box_inside', '%R|%n $*',
1148 'box_footer', '%R`--<%n$*%R>->%n',
1149 ]);
1150
1151 foreach my $cmd ( ( 'check', 'install', 'update', 'contact', 'search', '-h', 'help', 'ratings', 'rate', 'info', 'echo', 'top', 'cpan', 'autorun', 'new') ) {
1152     Irssi::command_bind('scriptassist '.$cmd => sub {
1153                         cmd_scripassist("$cmd ".$_[0], $_[1], $_[2]); });
1154     if (Irssi::settings_get_bool('scriptassist_integrate')) {
1155         Irssi::command_bind('script '.$cmd => sub {
1156                             cmd_scripassist("$cmd ".$_[0], $_[1], $_[2]); });
1157     }
1158 }
1159
1160 print CLIENTCRAP '%B>>%n '.$IRSSI{name}.' '.$VERSION.' loaded: /scriptassist help for help';