964 lines
21 KiB
Perl
964 lines
21 KiB
Perl
# line 1 "Xchat.pm"
|
|
BEGIN {
|
|
$INC{'Xchat.pm'} = 'DUMMY';
|
|
}
|
|
|
|
$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/;
|
|
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 = 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;
|
|
$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 hook_server {
|
|
return undef unless @_ >= 2;
|
|
my $message = shift;
|
|
my $callback = shift;
|
|
my $options = shift;
|
|
my $package = Xchat::Embed::find_pkg();
|
|
|
|
$callback = Xchat::Embed::fix_callback( $package, $callback );
|
|
|
|
my ($priority, $data) = ( Xchat::PRI_NORM, undef );
|
|
|
|
if( ref( $options ) eq 'HASH' ) {
|
|
if( exists( $options->{priority} ) && defined( $options->{priority} ) ) {
|
|
$priority = $options->{priority};
|
|
}
|
|
|
|
if( exists( $options->{data} ) && defined( $options->{data} ) ) {
|
|
$data = $options->{data};
|
|
}
|
|
}
|
|
|
|
my $pkg_info = Xchat::Embed::pkg_info( $package );
|
|
my $hook = Xchat::Internal::hook_server(
|
|
$message, $priority, $callback, $data
|
|
);
|
|
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 = Xchat::Embed::find_pkg();
|
|
|
|
$callback = Xchat::Embed::fix_callback( $package, $callback );
|
|
|
|
my ($priority, $help_text, $data) = ( Xchat::PRI_NORM, undef, undef );
|
|
|
|
if( ref( $options ) eq 'HASH' ) {
|
|
if( exists( $options->{priority} ) && defined( $options->{priority} ) ) {
|
|
$priority = $options->{priority};
|
|
}
|
|
|
|
if(
|
|
exists( $options->{help_text} )
|
|
&& defined( $options->{help_text} )
|
|
) {
|
|
$help_text = $options->{help_text};
|
|
}
|
|
|
|
if ( exists( $options->{data} ) && defined( $options->{data} ) ) {
|
|
$data = $options->{data};
|
|
}
|
|
}
|
|
|
|
my $pkg_info = Xchat::Embed::pkg_info( $package );
|
|
my $hook = Xchat::Internal::hook_command(
|
|
$command, $priority, $callback, $help_text, $data
|
|
);
|
|
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 = Xchat::Embed::find_pkg();
|
|
|
|
$callback = Xchat::Embed::fix_callback( $package, $callback );
|
|
|
|
my ($priority, $data) = ( Xchat::PRI_NORM, undef );
|
|
|
|
if ( ref( $options ) eq 'HASH' ) {
|
|
if ( exists( $options->{priority} ) && defined( $options->{priority} ) ) {
|
|
$priority = $options->{priority};
|
|
}
|
|
|
|
if ( exists( $options->{data} ) && defined( $options->{data} ) ) {
|
|
$data = $options->{data};
|
|
}
|
|
}
|
|
|
|
my $pkg_info = Xchat::Embed::pkg_info( $package );
|
|
my $hook = Xchat::Internal::hook_print(
|
|
$event, $priority, $callback, $data
|
|
);
|
|
push @{$pkg_info->{hooks}}, $hook if defined $hook;
|
|
return $hook;
|
|
}
|
|
|
|
sub hook_timer {
|
|
return undef unless @_ >= 2;
|
|
my ($timeout, $callback, $data) = @_;
|
|
my $package = Xchat::Embed::find_pkg();
|
|
|
|
$callback = Xchat::Embed::fix_callback( $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) = Xchat::Embed::find_pkg();
|
|
$callback = Xchat::Embed::fix_callback( $package, $callback );
|
|
|
|
my ($flags, $data) = (Xchat::FD_READ, undef);
|
|
|
|
if( ref( $options ) eq 'HASH' ) {
|
|
if( exists( $options->{flags} ) && defined( $options->{flags} ) ) {
|
|
$flags = $options->{flags};
|
|
}
|
|
|
|
if ( exists( $options->{data} ) && defined( $options->{data} ) ) {
|
|
$data = $options->{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,
|
|
}
|
|
);
|
|
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;
|
|
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(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];
|
|
}
|
|
}
|
|
|
|
} # end of Xchat package
|
|
|
|
{
|
|
package Xchat::Embed;
|
|
use strict;
|
|
use warnings;
|
|
# list of loaded scripts keyed by their package names
|
|
our %scripts;
|
|
|
|
sub load {
|
|
my $file = expand_homedir( shift @_ );
|
|
my $package = file2pkg( $file );
|
|
|
|
if( exists $scripts{$package} ) {
|
|
my $pkg_info = pkg_info( $package );
|
|
my $filename = File::Basename::basename( $pkg_info->{filename} );
|
|
Xchat::printf(
|
|
qq{'%s' already loaded from '%s'.\n},
|
|
$filename, $pkg_info->{filename}
|
|
);
|
|
Xchat::print(
|
|
'If this is a different script then it rename and try '.
|
|
'loading it again.'
|
|
);
|
|
return 2;
|
|
}
|
|
|
|
if( open my $source_handle, $file ) {
|
|
my $source = do {local $/; <$source_handle>};
|
|
close $source_handle;
|
|
# we shouldn't care about things after __END__
|
|
$source =~ s/^__END__.*//ms;
|
|
|
|
if(
|
|
my @replacements = $source =~
|
|
m/^\s*package ((?:[^\W:]+(?:::)?)+)\s*?;/mg
|
|
) {
|
|
|
|
if ( @replacements > 1 ) {
|
|
Xchat::print(
|
|
"Too many package defintions, only 1 is allowed\n"
|
|
);
|
|
return 1;
|
|
}
|
|
|
|
my $original_package = shift @replacements;
|
|
|
|
# remove original package declaration
|
|
$source =~ s/^(package $original_package\s*;)/#$1/m;
|
|
|
|
# fixes things up for code calling subs with fully qualified names
|
|
$source =~ s/${original_package}:://g;
|
|
}
|
|
|
|
# this must come before the eval or the filename will not be found in
|
|
# Xchat::register
|
|
$scripts{$package}{filename} = $file;
|
|
$scripts{$package}{loaded_at} = Time::HiRes::time();
|
|
|
|
my $full_path = File::Spec->rel2abs( $file );
|
|
$source =~ s/^/#line 1 "$full_path"\n\x7Bpackage $package;/;
|
|
|
|
# make sure we add the closing } even if the last line is a comment
|
|
if( $source =~ /^#.*\Z/m ) {
|
|
$source =~ s/^(?=#.*\Z)/\x7D/m;
|
|
} else {
|
|
$source =~ s/\Z/\x7D/;
|
|
}
|
|
|
|
_do_eval( $source );
|
|
|
|
unless( exists $scripts{$package}{gui_entry} ) {
|
|
$scripts{$package}{gui_entry} =
|
|
Xchat::Internal::register(
|
|
"", "unknown", "", $file
|
|
);
|
|
}
|
|
|
|
if( $@ ) {
|
|
# something went wrong
|
|
$@ =~ s/\(eval \d+\)/$file/g;
|
|
Xchat::print( "Error loading '$file':\n$@\n" );
|
|
# make sure the script list doesn't contain false information
|
|
unload( $scripts{$package}{filename} );
|
|
return 1;
|
|
}
|
|
} else {
|
|
Xchat::print( "Error opening '$file': $!\n" );
|
|
return 2;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub _do_eval {
|
|
no strict;
|
|
no warnings;
|
|
eval $_[0];
|
|
}
|
|
|
|
sub unload {
|
|
my $file = shift @_;
|
|
my $package = file2pkg( $file );
|
|
my $pkg_info = pkg_info( $package );
|
|
|
|
if( $pkg_info ) {
|
|
# take care of the shutdown callback
|
|
if( exists $pkg_info->{shutdown} ) {
|
|
# allow incorrectly written scripts to be unloaded
|
|
eval {
|
|
if( ref $pkg_info->{shutdown} eq 'CODE' ) {
|
|
$pkg_info->{shutdown}->();
|
|
} elsif ( $pkg_info->{shutdown} ) {
|
|
no strict 'refs';
|
|
&{$pkg_info->{shutdown}};
|
|
}
|
|
};
|
|
}
|
|
|
|
if( exists $pkg_info->{hooks} ) {
|
|
for my $hook ( @{$pkg_info->{hooks}} ) {
|
|
Xchat::unhook( $hook, $package );
|
|
}
|
|
}
|
|
|
|
|
|
if( exists $pkg_info->{gui_entry} ) {
|
|
plugingui_remove( $pkg_info->{gui_entry} );
|
|
}
|
|
|
|
Symbol::delete_package( $package );
|
|
delete $scripts{$package};
|
|
return Xchat::EAT_ALL;
|
|
} else {
|
|
Xchat::print( qq{"$file" is not loaded.\n} );
|
|
return Xchat::EAT_NONE;
|
|
}
|
|
}
|
|
|
|
sub unload_all {
|
|
for my $package ( keys %scripts ) {
|
|
unload( $scripts{$package}->{filename} );
|
|
}
|
|
|
|
return Xchat::EAT_ALL;
|
|
}
|
|
|
|
sub reload {
|
|
my $file = shift @_;
|
|
my $package = file2pkg( $file );
|
|
my $pkg_info = pkg_info( $package );
|
|
my $fullpath = $file;
|
|
|
|
if( $pkg_info ) {
|
|
$fullpath = $pkg_info->{filename};
|
|
unload( $file );
|
|
}
|
|
|
|
load( $fullpath );
|
|
return Xchat::EAT_ALL;
|
|
}
|
|
|
|
sub reload_all {
|
|
my @dirs = Xchat::get_info( "xchatdirfs" ) || Xchat::get_info( "xchatdir" );
|
|
push @dirs, File::Spec->catdir( $dirs[0], "plugins" );
|
|
for my $dir ( @dirs ) {
|
|
my $auto_load_glob = File::Spec->catfile( $dir, "*.pl" );
|
|
my @scripts = map { $_->{filename} }
|
|
sort { $a->{loaded_at} <=> $b->{loaded_at} } values %scripts;
|
|
push @scripts, File::Glob::bsd_glob( $auto_load_glob );
|
|
|
|
my %seen;
|
|
@scripts = grep { !$seen{ $_ }++ } @scripts;
|
|
|
|
unload_all();
|
|
for my $script ( @scripts ) {
|
|
if( !pkg_info( file2pkg( $script ) ) ) {
|
|
load( $script );
|
|
}
|
|
}
|
|
}
|
|
}
|
|
#sub auto_load {
|
|
# my $dir = Xchat::get_info( "xchatdirfs" ) || Xchat::get_info( "xchatdir" );
|
|
#
|
|
# if( opendir my $dir_handle, $dir ) {
|
|
# my @files = readdir $dir_handle;
|
|
#
|
|
# for( @files ) {
|
|
# my $fullpath = File::Spec->catfile( $dir, $_ );
|
|
# load( $fullpath ) if $fullpath =~ m/\.pl$/i;
|
|
# }
|
|
#
|
|
# closedir $dir_handle;
|
|
# }
|
|
#}
|
|
|
|
sub expand_homedir {
|
|
my $file = shift @_;
|
|
|
|
if ( $^O eq "MSWin32" ) {
|
|
$file =~ s/^~/$ENV{USERPROFILE}/;
|
|
} else {
|
|
$file =~ s{^~}{
|
|
(getpwuid($>))[7] || $ENV{HOME} || $ENV{LOGDIR}
|
|
}ex;
|
|
}
|
|
return $file;
|
|
}
|
|
|
|
sub file2pkg {
|
|
my $string = File::Basename::basename( shift @_ );
|
|
$string =~ s/\.pl$//i;
|
|
$string =~ s|([^A-Za-z0-9/])|'_'.unpack("H*",$1)|eg;
|
|
return "Xchat::Script::" . $string;
|
|
}
|
|
|
|
sub pkg_info {
|
|
my $package = shift @_;
|
|
return $scripts{$package};
|
|
}
|
|
|
|
sub find_external_pkg {
|
|
my $level = 1;
|
|
|
|
while( my @frame = caller( $level ) ) {
|
|
return @frame if $frame[0] !~ /^Xchat/;
|
|
$level++;
|
|
}
|
|
|
|
}
|
|
|
|
sub find_pkg {
|
|
my $level = 1;
|
|
|
|
while( my ($package, $file, $line) = caller( $level ) ) {
|
|
return $package if $package =~ /^Xchat::Script::/;
|
|
$level++;
|
|
}
|
|
|
|
my @frame = find_external_pkg();
|
|
my $location;
|
|
|
|
if( $frame[0] or $frame[1] ) {
|
|
$location = $frame[1] ? $frame[1] : "package $frame[0]";
|
|
$location .= " line $frame[2]";
|
|
} else {
|
|
$location = "unknown location";
|
|
}
|
|
|
|
die "Unable to determine which script this hook belongs to. at $location\n";
|
|
|
|
}
|
|
|
|
sub fix_callback {
|
|
my ($package, $callback) = @_;
|
|
|
|
unless( ref $callback ) {
|
|
# change the package to the correct one in case it was hardcoded
|
|
$callback =~ s/^.*:://;
|
|
$callback = qq[${package}::$callback];
|
|
|
|
no strict 'subs';
|
|
$callback = \&{$callback};
|
|
}
|
|
|
|
return $callback;
|
|
}
|
|
} # end of Xchat::Embed package
|
|
|
|
{
|
|
package Xchat::List::Network;
|
|
use strict;
|
|
use warnings;
|
|
use Storable qw(dclone);
|
|
my $last_modified;
|
|
my @servers;
|
|
|
|
sub get {
|
|
my $server_file = Xchat::get_info( "xchatdirfs" ) . "/servlist_.conf";
|
|
|
|
# recreate the list only if the server list file has changed
|
|
if( -f $server_file &&
|
|
(!defined $last_modified || $last_modified != -M $server_file ) ) {
|
|
$last_modified = -M _;
|
|
|
|
if( open my $fh, "<", $server_file ) {
|
|
local $/ = "\n\n";
|
|
while( my $record = <$fh> ) {
|
|
chomp $record;
|
|
next if $record =~ /^v=/; # skip the version line
|
|
push @servers, Xchat::List::Network::Entry::parse( $record );
|
|
}
|
|
} else {
|
|
warn "Unable to open '$server_file': $!";
|
|
}
|
|
}
|
|
|
|
my $clone = dclone( \@servers );
|
|
return @$clone;
|
|
}
|
|
} # end of Xchat::List::Network
|
|
|
|
{
|
|
package Xchat::List::Network::Entry;
|
|
use strict;
|
|
use warnings;
|
|
|
|
my %key_for = (
|
|
I => "irc_nick1",
|
|
i => "irc_nick2",
|
|
U => "irc_user_name",
|
|
R => "irc_real_name",
|
|
P => "server_password",
|
|
B => "nickserv_password",
|
|
N => "network",
|
|
D => "selected",
|
|
E => "encoding",
|
|
);
|
|
my $letter_key_re = join "|", keys %key_for;
|
|
|
|
sub parse {
|
|
my $data = shift;
|
|
my $entry = {
|
|
irc_nick1 => undef,
|
|
irc_nick2 => undef,
|
|
irc_user_name => undef,
|
|
irc_real_name => undef,
|
|
server_password => undef,
|
|
|
|
# the order of the channels need to be maintained
|
|
# list of { channel => .., key => ... }
|
|
autojoins => Xchat::List::Network::AutoJoin->new( '' ),
|
|
connect_commands => [],
|
|
flags => {},
|
|
selected => undef,
|
|
encoding => undef,
|
|
servers => [],
|
|
nickserv_password => undef,
|
|
network => undef,
|
|
};
|
|
|
|
my @fields = split /\n/, $data;
|
|
chomp @fields;
|
|
|
|
for my $field ( @fields ) {
|
|
SWITCH: for ( $field ) {
|
|
/^($letter_key_re)=(.*)/ && do {
|
|
$entry->{ $key_for{ $1 } } = $2;
|
|
last SWITCH;
|
|
};
|
|
|
|
/^J.(.*)/ && do {
|
|
$entry->{ autojoins } =
|
|
Xchat::List::Network::AutoJoin->new( $1 );
|
|
};
|
|
|
|
/^F.(.*)/ && do {
|
|
$entry->{ flags } = parse_flags( $1 );
|
|
};
|
|
|
|
/^S.(.+)/ && do {
|
|
push @{$entry->{servers}}, parse_server( $1 );
|
|
};
|
|
|
|
/^C.(.+)/ && do {
|
|
push @{$entry->{connect_commands}}, $1;
|
|
};
|
|
}
|
|
}
|
|
|
|
# $entry->{ autojoins } = $entry->{ autojoin_channels };
|
|
return $entry;
|
|
}
|
|
|
|
sub parse_flags {
|
|
my $value = shift || 0;
|
|
my %flags;
|
|
|
|
$flags{ "cycle" } = $value & 1 ? 1 : 0;
|
|
$flags{ "use_global" } = $value & 2 ? 1 : 0;
|
|
$flags{ "use_ssl" } = $value & 4 ? 1 : 0;
|
|
$flags{ "autoconnect" } = $value & 8 ? 1 : 0;
|
|
$flags{ "use_proxy" } = $value & 16 ? 1 : 0;
|
|
$flags{ "allow_invalid" } = $value & 32 ? 1 : 0;
|
|
|
|
return \%flags;
|
|
}
|
|
|
|
sub parse_server {
|
|
my $data = shift;
|
|
if( $data ) {
|
|
my ($host, $port) = split /\//, $data;
|
|
unless( $port ) {
|
|
my @parts = split /:/, $host;
|
|
|
|
# if more than 2 then we are probably dealing with a IPv6 address
|
|
# if less than 2 then no port was specified
|
|
if( @parts == 2 ) {
|
|
$port = $parts[1];
|
|
}
|
|
}
|
|
|
|
$port ||= 6667;
|
|
return { host => $host, port => $port };
|
|
}
|
|
}
|
|
|
|
} # end of Xchat::List::Network::Entry
|
|
|
|
{
|
|
package Xchat::List::Network::AutoJoin;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use overload
|
|
# '%{}' => \&as_hash,
|
|
# '@{}' => \&as_array,
|
|
'""' => 'as_string',
|
|
'0+' => 'as_bool';
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $line = shift;
|
|
|
|
my @autojoins;
|
|
|
|
if ( $line ) {
|
|
my ( $channels, $keys ) = split / /, $line, 2;
|
|
my @channels = split /,/, $channels;
|
|
my @keys = split /,/, ($keys || '');
|
|
|
|
for my $channel ( @channels ) {
|
|
my $key = shift @keys;
|
|
$key = '' unless defined $key;
|
|
|
|
push @autojoins, {
|
|
channel => $channel,
|
|
key => $key,
|
|
};
|
|
}
|
|
}
|
|
return bless \@autojoins, $class;
|
|
}
|
|
|
|
sub channels {
|
|
my $self = shift;
|
|
|
|
if( wantarray ) {
|
|
return map { $_->{channel} } @$self;
|
|
} else {
|
|
return scalar @$self;
|
|
}
|
|
}
|
|
|
|
sub keys {
|
|
my $self = shift;
|
|
return map { $_->{key} } @$self ;
|
|
|
|
}
|
|
|
|
sub pairs {
|
|
my $self = shift;
|
|
|
|
my @channels = $self->channels;
|
|
my @keys = $self->keys;
|
|
|
|
my @pairs = map { $_ => shift @keys } @channels;
|
|
}
|
|
|
|
sub as_hash {
|
|
my $self = shift;
|
|
return +{ $self->pairs };
|
|
}
|
|
|
|
sub as_string {
|
|
my $self = shift;
|
|
return join " ",
|
|
join( ",", $self->channels ),
|
|
join( ",", $self->keys );
|
|
}
|
|
|
|
sub as_array {
|
|
my $self = shift;
|
|
return [ map { \%$_ } @$self ];
|
|
}
|
|
|
|
sub as_bool {
|
|
my $self = shift;
|
|
return $self->channels ? 1 : "";
|
|
}
|
|
|
|
} # end of Xchat::Server::AutoJoin
|
|
|
|
1;
|