$SIG{__WARN__} = sub {
my $message = shift @_;
my ($package) = caller;
# redirect Gtk/Glib errors and warnings back to STDERR
my $message_levels = qr/ERROR|CRITICAL|WARNING|MESSAGE|INFO|DEBUG/i;
if( $message =~ /^(?:Gtk|GLib|Gdk)(?:-\w+)?-$message_levels/i ) {
print STDERR $message;
} else {
if( defined &Xchat::Internal::print ) {
Xchat::print( $message );
} else {
warn $message;
}
}
};
use File::Spec ();
use File::Basename ();
use File::Glob ();
use List::Util ();
use Symbol();
use Time::HiRes ();
use Carp ();
package Xchat;
use base qw(Exporter);
use strict;
use warnings;
sub PRI_HIGHEST ();
sub PRI_HIGH ();
sub PRI_NORM ();
sub PRI_LOW ();
sub PRI_LOWEST ();
sub EAT_NONE ();
sub EAT_XCHAT ();
sub EAT_PLUIN ();
sub EAT_ALL ();
sub KEEP ();
sub REMOVE ();
sub FD_READ ();
sub FD_WRITE ();
sub FD_EXCEPTION ();
sub FD_NOTSOCKET ();
sub get_context;
sub Xchat::Internal::context_info;
sub Xchat::Internal::print;
our %EXPORT_TAGS = (
constants => [
qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW PRI_LOWEST), # priorities
qw(EAT_NONE EAT_XCHAT EAT_PLUGIN EAT_ALL), # callback return values
qw(FD_READ FD_WRITE FD_EXCEPTION FD_NOTSOCKET), # fd flags
qw(KEEP REMOVE), # timers
],
hooks => [
qw(hook_server hook_command hook_print hook_timer hook_fd unhook),
],
util => [
qw(register nickcmp strip_code send_modes), # misc
qw(print prnt printf prntf command commandf emit_print), # output
qw(find_context get_context set_context), # context
qw(get_info get_prefs get_list context_info user_info), # input
],
);
$EXPORT_TAGS{all} = [ map { @{$_} } @EXPORT_TAGS{qw(constants hooks util)}];
our @EXPORT = @{$EXPORT_TAGS{constants}};
our @EXPORT_OK = @{$EXPORT_TAGS{all}};
sub register {
my ($package, $calling_package) = Xchat::Embed::find_pkg();
my $pkg_info = Xchat::Embed::pkg_info( $package );
my $filename = $pkg_info->{filename};
my ($name, $version, $description, $callback) = @_;
if( defined $pkg_info->{gui_entry} ) {
Xchat::print( "Xchat::register called more than once in "
. $pkg_info->{filename} );
return ();
}
$description = "" unless defined $description;
if( $callback ) {
$callback = Xchat::Embed::fix_callback(
$package, $calling_package, $callback
);
}
$pkg_info->{shutdown} = $callback;
unless( $name && $name =~ /[[:print:]\w]/ ) {
$name = "Not supplied";
}
unless( $version && $version =~ /\d+(?:\.\d+)?/ ) {
$version = "NaN";
}
$pkg_info->{gui_entry} =
Xchat::Internal::register( $name, $version, $description, $filename );
# keep with old behavior
return ();
}
sub _process_hook_options {
my ($options, $keys, $store) = @_;
unless( @$keys == @$store ) {
die 'Number of keys must match the size of the store';
}
my @results;
if( ref( $options ) eq 'HASH' ) {
for my $index ( 0 .. @$keys - 1 ) {
my $key = $keys->[$index];
if( exists( $options->{ $key } ) && defined( $options->{ $key } ) ) {
${$store->[$index]} = $options->{ $key };
}
}
}
}
sub hook_server {
return undef unless @_ >= 2;
my $message = shift;
my $callback = shift;
my $options = shift;
my ($package, $calling_package) = Xchat::Embed::find_pkg();
$callback = Xchat::Embed::fix_callback(
$package, $calling_package, $callback
);
my ($priority, $data) = ( Xchat::PRI_NORM, undef );
_process_hook_options(
$options,
[qw(priority data)],
[\($priority, $data)],
);
my $pkg_info = Xchat::Embed::pkg_info( $package );
my $hook = Xchat::Internal::hook_server(
$message, $priority, $callback, $data, $package
);
push @{$pkg_info->{hooks}}, $hook if defined $hook;
return $hook;
}
sub hook_command {
return undef unless @_ >= 2;
my $command = shift;
my $callback = shift;
my $options = shift;
my ($package, $calling_package) = Xchat::Embed::find_pkg();
$callback = Xchat::Embed::fix_callback(
$package, $calling_package, $callback
);
my ($priority, $help_text, $data) = ( Xchat::PRI_NORM, undef, undef );
_process_hook_options(
$options,
[qw(priority help_text data)],
[\($priority, $help_text, $data)],
);
my $pkg_info = Xchat::Embed::pkg_info( $package );
my $hook = Xchat::Internal::hook_command(
$command, $priority, $callback, $help_text, $data, $package
);
push @{$pkg_info->{hooks}}, $hook if defined $hook;
return $hook;
}
sub hook_print {
return undef unless @_ >= 2;
my $event = shift;
my $callback = shift;
my $options = shift;
my ($package, $calling_package) = Xchat::Embed::find_pkg();
$callback = Xchat::Embed::fix_callback(
$package, $calling_package, $callback
);
my ($priority, $run_after, $filter, $data) = ( Xchat::PRI_NORM, 0, 0, undef );
_process_hook_options(
$options,
[qw(priority run_after_event filter data)],
[\($priority, $run_after, $filter, $data)],
);
if( $run_after and $filter ) {
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" );
return;
}
if( $run_after ) {
my $cb = $callback;
$callback = sub {
my @args = @_;
hook_timer( 0, sub {
$cb->( @args );
if( ref $run_after eq 'CODE' ) {
$run_after->( @args );
}
return REMOVE;
});
return EAT_NONE;
};
}
if( $filter ) {
my $cb = $callback;
$callback = sub {
my @args = @{$_[0]};
my $event_data = $_[1];
my $event_name = $event;
my $last_arg = @args - 1;
my @new = $cb->( \@args, $event_data, $event_name );
# allow changing event by returning the new value
if( @new > @args ) {
$event_name = pop @new;
}
# a filter can either return the new results or it can modify
# @_ in place.
if( @new == @args ) {
emit_print( $event_name, @new[ 0 .. $last_arg ] );
return EAT_ALL;
} elsif(
join( "\0", @{$_[0]} ) ne join( "\0", @args[ 0 .. $last_arg ] )
) {
emit_print( $event_name, @args[ 0 .. $last_arg ] );
return EAT_ALL;
}
return EAT_NONE;
};
}
my $pkg_info = Xchat::Embed::pkg_info( $package );
my $hook = Xchat::Internal::hook_print(
$event, $priority, $callback, $data, $package
);
push @{$pkg_info->{hooks}}, $hook if defined $hook;
return $hook;
}
sub hook_timer {
return undef unless @_ >= 2;
my ($timeout, $callback, $data) = @_;
my ($package, $calling_package) = Xchat::Embed::find_pkg();
$callback = Xchat::Embed::fix_callback(
$package, $calling_package, $callback
);
if(
ref( $data ) eq 'HASH' && exists( $data->{data} )
&& defined( $data->{data} )
) {
$data = $data->{data};
}
my $pkg_info = Xchat::Embed::pkg_info( $package );
my $hook = Xchat::Internal::hook_timer( $timeout, $callback, $data, $package );
push @{$pkg_info->{hooks}}, $hook if defined $hook;
return $hook;
}
sub hook_fd {
return undef unless @_ >= 2;
my ($fd, $callback, $options) = @_;
return undef unless defined $fd && defined $callback;
my $fileno = fileno $fd;
return undef unless defined $fileno; # no underlying fd for this handle
my ($package, $calling_package) = Xchat::Embed::find_pkg();
$callback = Xchat::Embed::fix_callback(
$package, $calling_package, $callback
);
my ($flags, $data) = (Xchat::FD_READ, undef);
_process_hook_options(
$options,
[qw(flags data)],
[\($flags, $data)],
);
my $cb = sub {
my $userdata = shift;
return $userdata->{CB}->(
$userdata->{FD}, $userdata->{FLAGS}, $userdata->{DATA},
);
};
my $pkg_info = Xchat::Embed::pkg_info( $package );
my $hook = Xchat::Internal::hook_fd(
$fileno, $cb, $flags, {
DATA => $data, FD => $fd, CB => $callback, FLAGS => $flags,
},
$package
);
push @{$pkg_info->{hooks}}, $hook if defined $hook;
return $hook;
}
sub unhook {
my $hook = shift @_;
my $package = shift @_;
($package) = caller unless $package;
my $pkg_info = Xchat::Embed::pkg_info( $package );
if( defined( $hook )
&& $hook =~ /^\d+$/
&& grep { $_ == $hook } @{$pkg_info->{hooks}} ) {
$pkg_info->{hooks} = [grep { $_ != $hook } @{$pkg_info->{hooks}}];
return Xchat::Internal::unhook( $hook );
}
return ();
}
sub _do_for_each {
my ($cb, $channels, $servers) = @_;
# not specifying any channels or servers is not the same as specifying
# undef for both
# - not specifying either results in calling the callback inthe current ctx
# - specifying undef for for both results in calling the callback in the
# front/currently selected tab
if( @_ == 3 && !($channels || $servers) ) {
$channels = [ undef ];
$servers = [ undef ];
} elsif( !($channels || $servers) ) {
$cb->();
return 1;
}
$channels = [ $channels ] unless ref( $channels ) eq 'ARRAY';
if( $servers ) {
$servers = [ $servers ] unless ref( $servers ) eq 'ARRAY';
} else {
$servers = [ undef ];
}
my $num_done = 0;
my $old_ctx = Xchat::get_context();
for my $server ( @$servers ) {
for my $channel ( @$channels ) {
if( Xchat::set_context( $channel, $server ) ) {
$cb->();
$num_done++
}
}
}
Xchat::set_context( $old_ctx );
return $num_done;
}
sub print {
my $text = shift @_;
return "" unless defined $text;
if( ref( $text ) eq 'ARRAY' ) {
if( $, ) {
$text = join $, , @$text;
} else {
$text = join "", @$text;
}
}
return _do_for_each(
sub { Xchat::Internal::print( $text ); },
@_
);
}
sub printf {
my $format = shift;
Xchat::print( sprintf( $format, @_ ) );
}
# make Xchat::prnt() and Xchat::prntf() as aliases for Xchat::print() and
# Xchat::printf(), mainly useful when these functions are exported
sub prnt {
goto &Xchat::print;
}
sub prntf {
goto &Xchat::printf;
}
sub command {
my $command = shift;
return "" unless defined $command;
my @commands;
if( ref( $command ) eq 'ARRAY' ) {
@commands = @$command;
} else {
@commands = ($command);
}
return _do_for_each(
sub { Xchat::Internal::command( $_ ) foreach @commands },
@_
);
}
sub commandf {
my $format = shift;
Xchat::command( sprintf( $format, @_ ) );
}
sub set_context {
my $context;
if( @_ == 2 ) {
my ($channel, $server) = @_;
$context = Xchat::find_context( $channel, $server );
} elsif( @_ == 1 ) {
if( defined $_[0] && $_[0] =~ /^\d+$/ ) {
$context = $_[0];
} else {
$context = Xchat::find_context( $_[0] );
}
} elsif( @_ == 0 ) {
$context = Xchat::find_context();
}
return $context ? Xchat::Internal::set_context( $context ) : 0;
}
sub get_info {
my $id = shift;
my $info;
if( defined( $id ) ) {
if( grep { $id eq $_ } qw(state_cursor id) ) {
$info = Xchat::get_prefs( $id );
} else {
$info = Xchat::Internal::get_info( $id );
}
}
return $info;
}
sub user_info {
my $nick = Xchat::strip_code(shift @_ || Xchat::get_info( "nick" ));
my $user;
for (Xchat::get_list( "users" ) ) {
if ( Xchat::nickcmp( $_->{nick}, $nick ) == 0 ) {
$user = $_;
last;
}
}
return $user;
}
sub context_info {
my $ctx = shift @_ || Xchat::get_context;
my $old_ctx = Xchat::get_context;
my @fields = (
qw(away channel charset host id inputbox libdirfs modes network),
qw(nick nickserv server topic version win_ptr win_status),
qw(configdir xchatdir xchatdirfs state_cursor),
);
if( Xchat::set_context( $ctx ) ) {
my %info;
for my $field ( @fields ) {
$info{$field} = Xchat::get_info( $field );
}
my $ctx_info = Xchat::Internal::context_info;
@info{keys %$ctx_info} = values %$ctx_info;
Xchat::set_context( $old_ctx );
return %info if wantarray;
return \%info;
} else {
return undef;
}
}
sub get_list {
unless( grep { $_[0] eq $_ } qw(channels dcc ignore notify users networks) ) {
Carp::carp( "'$_[0]' does not appear to be a valid list name" );
}
if( $_[0] eq 'networks' ) {
return Xchat::List::Network->get();
} else {
return Xchat::Internal::get_list( $_[0] );
}
}
sub strip_code {
my $pattern = qr<
\cB| #Bold
\cC\d{0,2}(?:,\d{1,2})?| #Color
\e\[(?:\d{1,2}(?:;\d{1,2})*)?m| # ANSI color code
\cG| #Beep
\cO| #Reset
\cV| #Reverse
\c_ #Underline
>x;
if( defined wantarray ) {
my $msg = shift;
$msg =~ s/$pattern//g;
return $msg;
} else {
$_[0] =~ s/$pattern//g if defined $_[0];
}
}
1
