plugins/perl/lib/Xchat.pm

   1 $SIG{__WARN__} = sub {
   2         my $message = shift @_;
   3         my ($package) = caller;
   4
   5         # redirect Gtk/Glib errors and warnings back to STDERR
   6         my $message_levels =    qr/ERROR|CRITICAL|WARNING|MESSAGE|INFO|DEBUG/i;
   7         if( $message =~ /^(?:Gtk|GLib|Gdk)(?:-\w+)?-$message_levels/i ) {
   8                 print STDERR $message;
   9         } else {
  10
  11                 if( defined &Xchat::Internal::print ) {
  12                         Xchat::print( $message );
  13                 } else {
  14                         warn $message;
  15                 }
  16         }
  17 };
  18
  19 use File::Spec ();
  20 use File::Basename ();
  21 use File::Glob ();
  22 use List::Util ();
  23 use Symbol();
  24 use Time::HiRes ();
  25 use Carp ();
  26
  27 package Xchat;
  28 use base qw(Exporter);
  29 use strict;
  30 use warnings;
  31
  32 sub PRI_HIGHEST ();
  33 sub PRI_HIGH ();
  34 sub PRI_NORM ();
  35 sub PRI_LOW ();
  36 sub PRI_LOWEST ();
  37
  38 sub EAT_NONE ();
  39 sub EAT_XCHAT ();
  40 sub EAT_PLUIN ();
  41 sub EAT_ALL ();
  42
  43 sub KEEP ();
  44 sub REMOVE ();
  45 sub FD_READ ();
  46 sub FD_WRITE ();
  47 sub FD_EXCEPTION ();
  48 sub FD_NOTSOCKET ();
  49
  50 sub get_context;
  51 sub Xchat::Internal::context_info;
  52 sub Xchat::Internal::print;
  53
  54 our %EXPORT_TAGS = (
  55         constants => [
  56                 qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW PRI_LOWEST), # priorities
  57                 qw(EAT_NONE EAT_XCHAT EAT_PLUGIN EAT_ALL), # callback return values
  58                 qw(FD_READ FD_WRITE FD_EXCEPTION FD_NOTSOCKET), # fd flags
  59                 qw(KEEP REMOVE), # timers
  60         ],
  61         hooks => [
  62                 qw(hook_server hook_command hook_print hook_timer hook_fd unhook),
  63         ],
  64         util => [
  65                 qw(register nickcmp strip_code send_modes), # misc
  66                 qw(print prnt printf prntf command commandf emit_print), # output
  67                 qw(find_context get_context set_context), # context
  68                 qw(get_info get_prefs get_list context_info user_info), # input
  69         ],
  70 );
  71
  72 $EXPORT_TAGS{all} = [ map { @{$_} } @EXPORT_TAGS{qw(constants hooks util)}];
  73 our @EXPORT = @{$EXPORT_TAGS{constants}};
  74 our @EXPORT_OK = @{$EXPORT_TAGS{all}};
  75
  76 sub register {
  77         my ($package, $calling_package) = Xchat::Embed::find_pkg();
  78         my $pkg_info = Xchat::Embed::pkg_info( $package );
  79         my $filename = $pkg_info->{filename};
  80         my ($name, $version, $description, $callback) = @_;
  81
  82         if( defined $pkg_info->{gui_entry} ) {
  83                 Xchat::print( "Xchat::register called more than once in "
  84                         . $pkg_info->{filename} );
  85                 return ();
  86         }
  87
  88         $description = "" unless defined $description;
  89         if( $callback ) {
  90                 $callback = Xchat::Embed::fix_callback(
  91                         $package, $calling_package, $callback
  92                 );
  93         }
  94         $pkg_info->{shutdown} = $callback;
  95         unless( $name && $name =~ /[[:print:]\w]/ ) {
  96                 $name = "Not supplied";
  97         }
  98         unless( $version && $version =~ /\d+(?:\.\d+)?/ ) {
  99                 $version = "NaN";
 100         }
 101         $pkg_info->{gui_entry} =
 102                 Xchat::Internal::register( $name, $version, $description, $filename );
 103         # keep with old behavior
 104         return ();
 105 }
 106
 107 sub _process_hook_options {
 108         my ($options, $keys, $store) = @_;
 109
 110         unless( @$keys == @$store ) {
 111                 die 'Number of keys must match the size of the store';
 112         }
 113
 114         my @results;
 115
 116         if( ref( $options ) eq 'HASH' ) {
 117                 for my $index ( 0 .. @$keys - 1 ) {
 118                         my $key = $keys->[$index];
 119                         if( exists( $options->{ $key } ) && defined( $options->{ $key } ) ) {
 120                                 ${$store->[$index]} = $options->{ $key };
 121                         }
 122                 }
 123         }
 124
 125 }
 126
 127 sub hook_server {
 128         return undef unless @_ >= 2;
 129         my $message = shift;
 130         my $callback = shift;
 131         my $options = shift;
 132         my ($package, $calling_package) = Xchat::Embed::find_pkg();
 133
 134         $callback = Xchat::Embed::fix_callback(
 135                 $package, $calling_package, $callback
 136         );
 137
 138         my ($priority, $data) = ( Xchat::PRI_NORM, undef );
 139         _process_hook_options(
 140                 $options,
 141                 [qw(priority data)],
 142                 [\($priority, $data)],
 143         );
 144
 145         my $pkg_info = Xchat::Embed::pkg_info( $package );
 146         my $hook = Xchat::Internal::hook_server(
 147                 $message, $priority, $callback, $data, $package
 148         );
 149         push @{$pkg_info->{hooks}}, $hook if defined $hook;
 150         return $hook;
 151 }
 152
 153 sub hook_command {
 154         return undef unless @_ >= 2;
 155         my $command = shift;
 156         my $callback = shift;
 157         my $options = shift;
 158         my ($package, $calling_package) = Xchat::Embed::find_pkg();
 159
 160         $callback = Xchat::Embed::fix_callback(
 161                 $package, $calling_package, $callback
 162         );
 163
 164         my ($priority, $help_text, $data) = ( Xchat::PRI_NORM, undef, undef );
 165         _process_hook_options(
 166                 $options,
 167                 [qw(priority help_text data)],
 168                 [\($priority, $help_text, $data)],
 169         );
 170
 171         my $pkg_info = Xchat::Embed::pkg_info( $package );
 172         my $hook = Xchat::Internal::hook_command(
 173                 $command, $priority, $callback, $help_text, $data, $package
 174         );
 175         push @{$pkg_info->{hooks}}, $hook if defined $hook;
 176         return $hook;
 177 }
 178
 179 sub hook_print {
 180         return undef unless @_ >= 2;
 181         my $event = shift;
 182         my $callback = shift;
 183         my $options = shift;
 184         my ($package, $calling_package) = Xchat::Embed::find_pkg();
 185
 186         $callback = Xchat::Embed::fix_callback(
 187                 $package, $calling_package, $callback
 188         );
 189
 190         my ($priority, $run_after, $filter, $data) = ( Xchat::PRI_NORM, 0, 0, undef );
 191         _process_hook_options(
 192                 $options,
 193                 [qw(priority run_after_event filter data)],
 194                 [\($priority, $run_after, $filter, $data)],
 195         );
 196
 197         if( $run_after and $filter ) {
 198                 Carp::carp( "Xchat::hook_print's run_after_event and filter options are mutually exclusive, you can only use of them at a time per hook" );
 199                 return;
 200         }
 201
 202         if( $run_after ) {
 203                 my $cb = $callback;
 204                 $callback = sub {
 205                         my @args = @_;
 206                         hook_timer( 0, sub {
 207                                 $cb->( @args );
 208
 209                                 if( ref $run_after eq 'CODE' ) {
 210                                         $run_after->( @args );
 211                                 }
 212                                 return REMOVE;
 213                         });
 214                         return EAT_NONE;
 215                 };
 216         }
 217
 218         if( $filter ) {
 219                 my $cb = $callback;
 220                 $callback = sub {
 221                         my @args = @{$_[0]};
 222                         my $event_data = $_[1];
 223                         my $event_name = $event;
 224                         my $last_arg = @args - 1;
 225
 226                         my @new = $cb->( \@args, $event_data, $event_name );
 227
 228                         # allow changing event by returning the new value
 229                         if( @new > @args ) {
 230                                 $event_name = pop @new;
 231                         }
 232
 233                         # a filter can either return the new results or it can modify
 234                         # @_ in place.
 235                         if( @new == @args ) {
 236                                 emit_print( $event_name, @new[ 0 .. $last_arg ] );
 237                                 return EAT_ALL;
 238                         } elsif(
 239                                 join( "\0", @{$_[0]} ) ne join( "\0", @args[ 0 .. $last_arg ] )
 240                         ) {
 241                                 emit_print( $event_name, @args[ 0 .. $last_arg ] );
 242                                 return EAT_ALL;
 243                         }
 244
 245                         return EAT_NONE;
 246                 };
 247
 248         }
 249
 250         my $pkg_info = Xchat::Embed::pkg_info( $package );
 251         my $hook = Xchat::Internal::hook_print(
 252                 $event, $priority, $callback, $data, $package
 253         );
 254         push @{$pkg_info->{hooks}}, $hook if defined $hook;
 255         return $hook;
 256 }
 257
 258 sub hook_timer {
 259         return undef unless @_ >= 2;
 260         my ($timeout, $callback, $data) = @_;
 261         my ($package, $calling_package) = Xchat::Embed::find_pkg();
 262
 263         $callback = Xchat::Embed::fix_callback(
 264                 $package, $calling_package, $callback
 265         );
 266
 267         if(
 268                 ref( $data ) eq 'HASH' && exists( $data->{data} )
 269                 && defined( $data->{data} )
 270         ) {
 271                 $data = $data->{data};
 272         }
 273
 274         my $pkg_info = Xchat::Embed::pkg_info( $package );
 275         my $hook = Xchat::Internal::hook_timer( $timeout, $callback, $data, $package );
 276         push @{$pkg_info->{hooks}}, $hook if defined $hook;
 277         return $hook;
 278 }
 279
 280 sub hook_fd {
 281         return undef unless @_ >= 2;
 282         my ($fd, $callback, $options) = @_;
 283         return undef unless defined $fd && defined $callback;
 284
 285         my $fileno = fileno $fd;
 286         return undef unless defined $fileno; # no underlying fd for this handle
 287
 288         my ($package, $calling_package) = Xchat::Embed::find_pkg();
 289         $callback = Xchat::Embed::fix_callback(
 290                 $package, $calling_package, $callback
 291         );
 292
 293         my ($flags, $data) = (Xchat::FD_READ, undef);
 294         _process_hook_options(
 295                 $options,
 296                 [qw(flags data)],
 297                 [\($flags, $data)],
 298         );
 299
 300         my $cb = sub {
 301                 my $userdata = shift;
 302                 return $userdata->{CB}->(
 303                         $userdata->{FD}, $userdata->{FLAGS}, $userdata->{DATA},
 304                 );
 305         };
 306
 307         my $pkg_info = Xchat::Embed::pkg_info( $package );
 308         my $hook = Xchat::Internal::hook_fd(
 309                 $fileno, $cb, $flags, {
 310                         DATA => $data, FD => $fd, CB => $callback, FLAGS => $flags,
 311                 },
 312                 $package
 313         );
 314         push @{$pkg_info->{hooks}}, $hook if defined $hook;
 315         return $hook;
 316 }
 317
 318 sub unhook {
 319         my $hook = shift @_;
 320         my $package = shift @_;
 321         ($package) = caller unless $package;
 322         my $pkg_info = Xchat::Embed::pkg_info( $package );
 323
 324         if( defined( $hook )
 325                 && $hook =~ /^\d+$/
 326                 && grep { $_ == $hook } @{$pkg_info->{hooks}} ) {
 327                 $pkg_info->{hooks} = [grep { $_ != $hook } @{$pkg_info->{hooks}}];
 328                 return Xchat::Internal::unhook( $hook );
 329         }
 330         return ();
 331 }
 332
 333 sub _do_for_each {
 334         my ($cb, $channels, $servers) = @_;
 335
 336         # not specifying any channels or servers is not the same as specifying
 337         # undef for both
 338         # - not specifying either results in calling the callback inthe current ctx
 339         # - specifying undef for for both results in calling the callback in the
 340         #   front/currently selected tab
 341         if( @_ == 3 && !($channels || $servers) ) {
 342                 $channels = [ undef ];
 343                 $servers = [ undef ];
 344         } elsif( !($channels || $servers) ) {
 345                 $cb->();
 346                 return 1;
 347         }
 348
 349         $channels = [ $channels ] unless ref( $channels ) eq 'ARRAY';
 350
 351         if( $servers ) {
 352                 $servers = [ $servers ] unless ref( $servers ) eq 'ARRAY';
 353         } else {
 354                 $servers = [ undef ];
 355         }
 356
 357         my $num_done = 0;
 358         my $old_ctx = Xchat::get_context();
 359         for my $server ( @$servers ) {
 360                 for my $channel ( @$channels ) {
 361                         if( Xchat::set_context( $channel, $server ) ) {
 362                                 $cb->();
 363                                 $num_done++
 364                         }
 365                 }
 366         }
 367         Xchat::set_context( $old_ctx );
 368         return $num_done;
 369 }
 370
 371 sub print {
 372         my $text = shift @_;
 373         return "" unless defined $text;
 374         if( ref( $text ) eq 'ARRAY' ) {
 375                 if( $, ) {
 376                         $text = join $, , @$text;
 377                 } else {
 378                         $text = join "", @$text;
 379                 }
 380         }
 381
 382         return _do_for_each(
 383                 sub { Xchat::Internal::print( $text ); },
 384                 @_
 385         );
 386 }
 387
 388 sub printf {
 389         my $format = shift;
 390         Xchat::print( sprintf( $format, @_ ) );
 391 }
 392
 393 # make Xchat::prnt() and Xchat::prntf() as aliases for Xchat::print() and
 394 # Xchat::printf(), mainly useful when these functions are exported
 395 sub prnt {
 396         goto &Xchat::print;
 397 }
 398
 399 sub prntf {
 400         goto &Xchat::printf;
 401 }
 402
 403 sub command {
 404         my $command = shift;
 405         return "" unless defined $command;
 406         my @commands;
 407
 408         if( ref( $command ) eq 'ARRAY' ) {
 409                 @commands = @$command;
 410         } else {
 411                 @commands = ($command);
 412         }
 413
 414         return _do_for_each(
 415                 sub { Xchat::Internal::command( $_ ) foreach @commands },
 416                 @_
 417         );
 418 }
 419
 420 sub commandf {
 421         my $format = shift;
 422         Xchat::command( sprintf( $format, @_ ) );
 423 }
 424
 425 sub set_context {
 426         my $context;
 427         if( @_ == 2 ) {
 428                 my ($channel, $server) = @_;
 429                 $context = Xchat::find_context( $channel, $server );
 430         } elsif( @_ == 1 ) {
 431                 if( defined $_[0] && $_[0] =~ /^\d+$/ ) {
 432                         $context = $_[0];
 433                 } else {
 434                         $context = Xchat::find_context( $_[0] );
 435                 }
 436         } elsif( @_ == 0 ) {
 437                 $context = Xchat::find_context();
 438         }
 439         return $context ? Xchat::Internal::set_context( $context ) : 0;
 440 }
 441
 442 sub get_info {
 443         my $id = shift;
 444         my $info;
 445
 446         if( defined( $id ) ) {
 447                 if( grep { $id eq $_ } qw(state_cursor id) ) {
 448                         $info = Xchat::get_prefs( $id );
 449                 } else {
 450                         $info = Xchat::Internal::get_info( $id );
 451                 }
 452         }
 453         return $info;
 454 }
 455
 456 sub user_info {
 457         my $nick = Xchat::strip_code(shift @_ || Xchat::get_info( "nick" ));
 458         my $user;
 459         for (Xchat::get_list( "users" ) ) {
 460                 if ( Xchat::nickcmp( $_->{nick}, $nick ) == 0 ) {
 461                         $user = $_;
 462                         last;
 463                 }
 464         }
 465         return $user;
 466 }
 467
 468 sub context_info {
 469         my $ctx = shift @_ || Xchat::get_context;
 470         my $old_ctx = Xchat::get_context;
 471         my @fields = (
 472                 qw(away channel charset host id inputbox libdirfs modes network),
 473                 qw(nick nickserv server topic version win_ptr win_status),
 474                 qw(xchatdir xchatdirfs state_cursor),
 475         );
 476
 477         if( Xchat::set_context( $ctx ) ) {
 478                 my %info;
 479                 for my $field ( @fields ) {
 480                         $info{$field} = Xchat::get_info( $field );
 481                 }
 482
 483                 my $ctx_info = Xchat::Internal::context_info;
 484                 @info{keys %$ctx_info} = values %$ctx_info;
 485
 486                 Xchat::set_context( $old_ctx );
 487                 return %info if wantarray;
 488                 return \%info;
 489         } else {
 490                 return undef;
 491         }
 492 }
 493
 494 sub get_list {
 495         unless( grep { $_[0] eq $_ } qw(channels dcc ignore notify users networks) ) {
 496                 Carp::carp( "'$_[0]' does not appear to be a valid list name" );
 497         }
 498         if( $_[0] eq 'networks' ) {
 499                 return Xchat::List::Network->get();
 500         } else {
 501                 return Xchat::Internal::get_list( $_[0] );
 502         }
 503 }
 504
 505 sub strip_code {
 506         my $pattern = qr<
 507                 \cB| #Bold
 508                 \cC\d{0,2}(?:,\d{1,2})?| #Color
 509                 \e\[(?:\d{1,2}(?:;\d{1,2})*)?m| # ANSI color code
 510                 \cG| #Beep
 511                 \cO| #Reset
 512                 \cV| #Reverse
 513                 \c_  #Underline
 514         >x;
 515
 516         if( defined wantarray ) {
 517                 my $msg = shift;
 518                 $msg =~ s/$pattern//g;
 519                 return $msg;
 520         } else {
 521                 $_[0] =~ s/$pattern//g if defined $_[0];
 522         }
 523 }
 524
 525 1