From 075cc61c942998b7fdfeabfde10490ef233f88cd Mon Sep 17 00:00:00 2001 From: Farow Date: Wed, 2 Oct 2013 17:47:56 +0300 Subject: Rebrand Perl plugin to HexChat, Add /pl and plugin_pref Add help messages --- plugins/perl/Makefile.am | 14 +- plugins/perl/generate_header | 13 +- plugins/perl/lib/HexChat.pm | 556 ++++++++++++++++++++++ plugins/perl/lib/HexChat/Embed.pm | 348 ++++++++++++++ plugins/perl/lib/HexChat/List/Network.pm | 33 ++ plugins/perl/lib/HexChat/List/Network/AutoJoin.pm | 80 ++++ plugins/perl/lib/HexChat/List/Network/Entry.pm | 106 +++++ plugins/perl/lib/Xchat.pm | 526 +------------------- plugins/perl/lib/Xchat/Embed.pm | 325 ------------- plugins/perl/lib/Xchat/List/Network.pm | 33 -- plugins/perl/lib/Xchat/List/Network/AutoJoin.pm | 80 ---- plugins/perl/lib/Xchat/List/Network/Entry.pm | 106 ----- plugins/perl/perl.c | 258 ++++++---- plugins/perl/perl.vcxproj | 4 +- 14 files changed, 1311 insertions(+), 1171 deletions(-) create mode 100644 plugins/perl/lib/HexChat.pm create mode 100644 plugins/perl/lib/HexChat/Embed.pm create mode 100644 plugins/perl/lib/HexChat/List/Network.pm create mode 100644 plugins/perl/lib/HexChat/List/Network/AutoJoin.pm create mode 100644 plugins/perl/lib/HexChat/List/Network/Entry.pm delete mode 100644 plugins/perl/lib/Xchat/Embed.pm delete mode 100644 plugins/perl/lib/Xchat/List/Network.pm delete mode 100644 plugins/perl/lib/Xchat/List/Network/AutoJoin.pm delete mode 100644 plugins/perl/lib/Xchat/List/Network/Entry.pm (limited to 'plugins/perl') diff --git a/plugins/perl/Makefile.am b/plugins/perl/Makefile.am index 02f29252..b54df005 100644 --- a/plugins/perl/Makefile.am +++ b/plugins/perl/Makefile.am @@ -1,6 +1,6 @@ -EXTRA_DIST=alt_completion.pl generate_header lib/Xchat.pm lib/Xchat/Embed.pm lib/Xchat/List/Network.pm \ - lib/Xchat/List/Network/Entry.pm lib/Xchat/List/Network/AutoJoin.pm lib/IRC.pm +EXTRA_DIST=alt_completion.pl generate_header lib/HexChat.pm lib/Xchat.pm lib/HexChat/Embed.pm lib/HexChat/List/Network.pm \ + lib/HexChat/List/Network/Entry.pm lib/HexChat/List/Network/AutoJoin.pm lib/IRC.pm libdir = $(hexchatlibdir) @@ -8,11 +8,11 @@ lib_LTLIBRARIES = perl.la perl_la_SOURCES = perl.c perl_la_LDFLAGS = -avoid-version -module perl_la_LIBADD = $(PERL_LDFLAGS) -BUILT_SOURCES = xchat.pm.h irc.pm.h +BUILT_SOURCES = hexchat.pm.h irc.pm.h #CFLAGS = @CFLAGS@ -Wno-unused AM_CPPFLAGS = $(PERL_CFLAGS) $(COMMON_CFLAGS) -I$(srcdir)/../../src/common -CLEANFILES = xchat.pm.h irc.pm.h -xchat.pm.h irc.pm.h: lib/Xchat.pm lib/Xchat/Embed.pm \ - lib/Xchat/List/Network.pm lib/Xchat/List/Network/Entry.pm \ - lib/Xchat/List/Network/AutoJoin.pm lib/IRC.pm +CLEANFILES = hexchat.pm.h irc.pm.h +hexchat.pm.h irc.pm.h: lib/HexChat.pm lib/Xchat.pm lib/HexChat/Embed.pm \ + lib/HexChat/List/Network.pm lib/HexChat/List/Network/Entry.pm \ + lib/HexChat/List/Network/AutoJoin.pm lib/IRC.pm perl generate_header diff --git a/plugins/perl/generate_header b/plugins/perl/generate_header index 37e7d323..7dd437ce 100644 --- a/plugins/perl/generate_header +++ b/plugins/perl/generate_header @@ -25,12 +25,13 @@ sub toc { } for my $files ( - [ "xchat.pm.h", # output file - "lib/Xchat.pm", # input files - "lib/Xchat/Embed.pm", - "lib/Xchat/List/Network.pm", - "lib/Xchat/List/Network/Entry.pm", - "lib/Xchat/List/Network/AutoJoin.pm", + [ "hexchat.pm.h", # output file + "lib/HexChat.pm", # input files + "lib/Xchat.pm", + "lib/HexChat/Embed.pm", + "lib/HexChat/List/Network.pm", + "lib/HexChat/List/Network/Entry.pm", + "lib/HexChat/List/Network/AutoJoin.pm", ], [ "irc.pm.h", # output file "lib/IRC.pm" # input file diff --git a/plugins/perl/lib/HexChat.pm b/plugins/perl/lib/HexChat.pm new file mode 100644 index 00000000..ebbed4fb --- /dev/null +++ b/plugins/perl/lib/HexChat.pm @@ -0,0 +1,556 @@ +$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 &HexChat::Internal::print ) { + HexChat::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 HexChat; +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_HEXCHAT (); +sub EAT_PLUGIN (); +sub EAT_ALL (); + +sub KEEP (); +sub REMOVE (); +sub FD_READ (); +sub FD_WRITE (); +sub FD_EXCEPTION (); +sub FD_NOTSOCKET (); + +sub get_context; +sub HexChat::Internal::context_info; +sub HexChat::Internal::print; + +#keep compability with Xchat scripts +sub EAT_XCHAT (); +BEGIN { + *Xchat:: = *HexChat::; +} + +our %EXPORT_TAGS = ( + constants => [ + qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW PRI_LOWEST), # priorities + qw(EAT_NONE EAT_HEXCHAT 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 + qw(plugin_pref_set plugin_pref_get plugin_pref_delete plugin_pref_list), #settings + ], +); + +$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) = HexChat::Embed::find_pkg(); + my $pkg_info = HexChat::Embed::pkg_info( $package ); + my $filename = $pkg_info->{filename}; + my ($name, $version, $description, $callback) = @_; + + if( defined $pkg_info->{gui_entry} ) { + HexChat::print( "HexChat::register called more than once in " + . $pkg_info->{filename} ); + return (); + } + + $description = "" unless defined $description; + if( $callback ) { + $callback = HexChat::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} = + HexChat::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) = HexChat::Embed::find_pkg(); + + $callback = HexChat::Embed::fix_callback( + $package, $calling_package, $callback + ); + + my ($priority, $data) = ( HexChat::PRI_NORM, undef ); + _process_hook_options( + $options, + [qw(priority data)], + [\($priority, $data)], + ); + + my $pkg_info = HexChat::Embed::pkg_info( $package ); + my $hook = HexChat::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) = HexChat::Embed::find_pkg(); + + $callback = HexChat::Embed::fix_callback( + $package, $calling_package, $callback + ); + + my ($priority, $help_text, $data) = ( HexChat::PRI_NORM, undef, undef ); + _process_hook_options( + $options, + [qw(priority help_text data)], + [\($priority, $help_text, $data)], + ); + + my $pkg_info = HexChat::Embed::pkg_info( $package ); + my $hook = HexChat::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) = HexChat::Embed::find_pkg(); + + $callback = HexChat::Embed::fix_callback( + $package, $calling_package, $callback + ); + + my ($priority, $run_after, $filter, $data) = ( HexChat::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( "HexChat::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 = HexChat::Embed::pkg_info( $package ); + my $hook = HexChat::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) = HexChat::Embed::find_pkg(); + + $callback = HexChat::Embed::fix_callback( + $package, $calling_package, $callback + ); + + if( + ref( $data ) eq 'HASH' && exists( $data->{data} ) + && defined( $data->{data} ) + ) { + $data = $data->{data}; + } + + my $pkg_info = HexChat::Embed::pkg_info( $package ); + my $hook = HexChat::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) = HexChat::Embed::find_pkg(); + $callback = HexChat::Embed::fix_callback( + $package, $calling_package, $callback + ); + + my ($flags, $data) = (HexChat::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 = HexChat::Embed::pkg_info( $package ); + my $hook = HexChat::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 = HexChat::Embed::pkg_info( $package ); + + if( defined( $hook ) + && $hook =~ /^\d+$/ + && grep { $_ == $hook } @{$pkg_info->{hooks}} ) { + $pkg_info->{hooks} = [grep { $_ != $hook } @{$pkg_info->{hooks}}]; + return HexChat::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 = HexChat::get_context(); + for my $server ( @$servers ) { + for my $channel ( @$channels ) { + if( HexChat::set_context( $channel, $server ) ) { + $cb->(); + $num_done++ + } + } + } + HexChat::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 { HexChat::Internal::print( $text ); }, + @_ + ); +} + +sub printf { + my $format = shift; + HexChat::print( sprintf( $format, @_ ) ); +} + +# make HexChat::prnt() and HexChat::prntf() as aliases for HexChat::print() and +# HexChat::printf(), mainly useful when these functions are exported +sub prnt { + goto &HexChat::print; +} + +sub prntf { + goto &HexChat::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 { HexChat::Internal::command( $_ ) foreach @commands }, + @_ + ); +} + +sub commandf { + my $format = shift; + HexChat::command( sprintf( $format, @_ ) ); +} + +sub plugin_pref_set { + my $setting = shift // return 0; + my $value = shift // return 0; + + return HexChat::Internal::plugin_pref_set($setting, $value); +} + +sub plugin_pref_get { + my $setting = shift // return 0; + + return HexChat::Internal::plugin_pref_get($setting); +} + +sub plugin_pref_delete { + my $setting = shift // return 0; + + return HexChat::Internal::plugin_pref_delete($setting); +} + +sub plugin_pref_list { + my %list = HexChat::Internal::plugin_pref_list(); + + return \%list; +} + +sub set_context { + my $context; + if( @_ == 2 ) { + my ($channel, $server) = @_; + $context = HexChat::find_context( $channel, $server ); + } elsif( @_ == 1 ) { + if( defined $_[0] && $_[0] =~ /^\d+$/ ) { + $context = $_[0]; + } else { + $context = HexChat::find_context( $_[0] ); + } + } elsif( @_ == 0 ) { + $context = HexChat::find_context(); + } + return $context ? HexChat::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 = HexChat::get_prefs( $id ); + } else { + $info = HexChat::Internal::get_info( $id ); + } + } + return $info; +} + +sub user_info { + my $nick = HexChat::strip_code(shift @_ || HexChat::get_info( "nick" )); + my $user; + for (HexChat::get_list( "users" ) ) { + if ( HexChat::nickcmp( $_->{nick}, $nick ) == 0 ) { + $user = $_; + last; + } + } + return $user; +} + +sub context_info { + my $ctx = shift @_ || HexChat::get_context; + my $old_ctx = HexChat::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( HexChat::set_context( $ctx ) ) { + my %info; + for my $field ( @fields ) { + $info{$field} = HexChat::get_info( $field ); + } + + my $ctx_info = HexChat::Internal::context_info; + @info{keys %$ctx_info} = values %$ctx_info; + + HexChat::set_context( $old_ctx ); + 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 HexChat::List::Network->get(); + } else { + return HexChat::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 diff --git a/plugins/perl/lib/HexChat/Embed.pm b/plugins/perl/lib/HexChat/Embed.pm new file mode 100644 index 00000000..c033d3c9 --- /dev/null +++ b/plugins/perl/lib/HexChat/Embed.pm @@ -0,0 +1,348 @@ +package HexChat::Embed; +use strict; +use warnings; +use Data::Dumper; +# list of loaded scripts keyed by their package names +# The package names are generated from the filename of the script using +# the file2pkg() function. +# The values of this hash are hash references with the following keys: +# filename +# The full path to the script. +# gui_entry +# This is hexchat_plugin pointer that is used to remove the script from +# Plugins and Scripts window when a script is unloaded. This has also +# been converted with the PTR2IV() macro. +# hooks +# This is an array of hooks that are associated with this script. +# These are pointers that have been converted with the PTR2IV() macro. +# inner_packages +# Other packages that are defined in a script. This is not recommended +# partly because these will also get removed when a script is unloaded. +# loaded_at +# A timestamp of when the script was loaded. The value is whatever +# Time::HiRes::time() returns. This is used to retain load order when +# using the RELOADALL command. +# shutdown +# This is either a code ref or undef. It will be executed just before a +# script is unloaded. +our %scripts; + +# This is a mapping of "inner package" => "containing script package" +our %owner_package; + +# used to keep track of which package a hook belongs to, if the normal way of +# checking which script is calling a hook function fails this will be used +# instead. When a hook is created this will be copied to the HookData structure +# and when a callback is invoked this it will be used to set this value. +our $current_package; + +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} ); + HexChat::printf( + qq{'%s' already loaded from '%s'.\n}, + $filename, $pkg_info->{filename} + ); + HexChat::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; + + # this must come before the eval or the filename will not be found in + # HexChat::register + $scripts{$package}{filename} = $file; + $scripts{$package}{loaded_at} = Time::HiRes::time(); + + # this must be done before the error check so the unload will remove + # any inner packages defined by the script. if a script fails to load + # then any inner packages need to be removed as well. + my @inner_packages = $source =~ + m/^\s*package \s+ + ((?:[^\W:]+(?:::)?)+)\s*? # package name + # strict version number + (?:\d+(?:[.]\d+) # positive integer or decimal-fraction + |v\d+(?:[.]\d+){2,})? # dotted-decimal v-string + [{;] + /mgx; + + # check if any inner package defined in the to be loaded script has + # already been defined by another script + my @conflicts; + for my $inner ( @inner_packages ) { + if( exists $owner_package{ $inner } ) { + push @conflicts, $inner; + } + } + + # report conflicts and bail out + if( @conflicts ) { + my $error_message = + "'$file' won't be loaded due to conflicting inner packages:\n"; + for my $conflict_package ( @conflicts ) { + $error_message .= " $conflict_package already defined in " . + pkg_info($owner_package{ $conflict_package })->{filename}."\n"; + } + HexChat::print( $error_message ); + + return 2; + } + + 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/; + } + + $scripts{$package}{inner_packages} = [ @inner_packages ]; + @owner_package{ @inner_packages } = ($package) x @inner_packages; + _do_eval( $source ); + + unless( exists $scripts{$package}{gui_entry} ) { + $scripts{$package}{gui_entry} = + HexChat::Internal::register( + "", "unknown", "", $file + ); + } + + if( $@ ) { + # something went wrong + $@ =~ s/\(eval \d+\)/$file/g; + HexChat::print( "Error loading '$file':\n$@\n" ); + # make sure the script list doesn't contain false information + unload( $scripts{$package}{filename} ); + return 1; + } + } else { + HexChat::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}} ) { + HexChat::unhook( $hook, $package ); + } + } + + if( exists $pkg_info->{gui_entry} ) { + plugingui_remove( $pkg_info->{gui_entry} ); + } + + delete @owner_package{ @{$pkg_info->{inner_packages}} }; + for my $inner_package ( @{$pkg_info->{inner_packages}} ) { + Symbol::delete_package( $inner_package ); + } + Symbol::delete_package( $package ); + delete $scripts{$package}; + return HexChat::EAT_ALL; + } else { + HexChat::print( qq{"$file" is not loaded.\n} ); + return HexChat::EAT_NONE; + } +} + +sub unload_all { + for my $package ( keys %scripts ) { + unload( $scripts{$package}->{filename} ); + } + + return HexChat::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 HexChat::EAT_ALL; +} + +sub reload_all { + my @dirs = HexChat::get_info( "configdir" ); + 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 evaluate { + my ($code) = @_; + + my @results = eval $code; + HexChat::print $@ if $@; #print warnings + + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Terse = 1; + + if (@results > 1) { + HexChat::print Dumper \@results; + } + elsif (ref $results[0] || !$results[0]) { + HexChat::print Dumper $results[0]; + } + else { + HexChat::print $results[0]; + } + + return HexChat::EAT_HEXCHAT; +}; + +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 "HexChat::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] !~ /(?:^IRC$|^HexChat)/; + $level++; + } + return; +} + +sub find_pkg { + my $level = 1; + + while( my ($package, $file, $line) = caller( $level ) ) { + return $package if $package =~ /^HexChat::Script::/; + $level++; + } + + my $current_package = get_current_package(); + if( defined $current_package ) { + return $current_package; + } + + my @frame = find_external_pkg(); + my $location; + + if( $frame[0] or $frame[1] ) { + my $calling_package = $frame[0]; + if( defined( my $owner = $owner_package{ $calling_package } ) ) { + return ($owner, $calling_package); + } + + $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"; + +} + +# convert function names into code references +sub fix_callback { + my ($package, $calling_package, $callback) = @_; + + unless( ref $callback ) { + unless( $callback =~ /::/ ) { + my $prefix = defined $calling_package ? $calling_package : $package; + $callback =~ s/^/${prefix}::/; + } + + no strict 'subs'; + $callback = \&{$callback}; + } + + return $callback; +} + +sub get_current_package { + return $current_package; +} + +sub set_current_package { + my $old_package = $current_package; + $current_package = shift; + + return $old_package; +} + +1 diff --git a/plugins/perl/lib/HexChat/List/Network.pm b/plugins/perl/lib/HexChat/List/Network.pm new file mode 100644 index 00000000..64b3d14c --- /dev/null +++ b/plugins/perl/lib/HexChat/List/Network.pm @@ -0,0 +1,33 @@ +package HexChat::List::Network; +use strict; +use warnings; +use Storable qw(dclone); +my $last_modified; +my @servers; + +sub get { + my $server_file = HexChat::get_info( "configdir" ) . "/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 _; + + @servers = (); + 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, HexChat::List::Network::Entry::parse( $record ); + } + } else { + warn "Unable to open '$server_file': $!"; + } + } + + my $clone = dclone( \@servers ); + return @$clone; +} + +1 diff --git a/plugins/perl/lib/HexChat/List/Network/AutoJoin.pm b/plugins/perl/lib/HexChat/List/Network/AutoJoin.pm new file mode 100644 index 00000000..cc51af25 --- /dev/null +++ b/plugins/perl/lib/HexChat/List/Network/AutoJoin.pm @@ -0,0 +1,80 @@ +package HexChat::List::Network::AutoJoin; +use strict; +use warnings; + +use overload +# '%{}' => \&as_hash, +# '@{}' => \&as_array, + '""' => 'as_string', + '0+' => 'as_bool'; + +sub new { + my $class = shift; + + my @autojoins; + + return bless \@autojoins, $class; +} + +sub add { + my $self = shift; + + my $line = shift; + + my ( $channel, $key ) = split /,/, $line, 2; + $key = $key || ''; + + push @$self, { + channel => $channel, + key => $key, + }; +} + +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 : ""; +} + +1 diff --git a/plugins/perl/lib/HexChat/List/Network/Entry.pm b/plugins/perl/lib/HexChat/List/Network/Entry.pm new file mode 100644 index 00000000..828a7791 --- /dev/null +++ b/plugins/perl/lib/HexChat/List/Network/Entry.pm @@ -0,0 +1,106 @@ +package HexChat::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 => HexChat::List::Network::AutoJoin->new( '' ), + connect_commands => [], + flags => {}, + selected => undef, + encoding => undef, + servers => [], + nickserv_password => undef, + network => undef, + }; + + my @fields = split /\n/, $data; + chomp @fields; + + $entry->{ autojoins } = HexChat::List::Network::AutoJoin->new(); + + for my $field ( @fields ) { + SWITCH: for ( $field ) { + /^($letter_key_re)=(.*)/ && do { + $entry->{ $key_for{ $1 } } = $2; + last SWITCH; + }; + + /^J.(.*)/ && do { + $entry->{ autojoins }->add( $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 }; + } +} + +1 diff --git a/plugins/perl/lib/Xchat.pm b/plugins/perl/lib/Xchat.pm index 1ead64c3..2a95674e 100644 --- a/plugins/perl/lib/Xchat.pm +++ b/plugins/perl/lib/Xchat.pm @@ -1,525 +1 @@ -$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 +require HexChat; diff --git a/plugins/perl/lib/Xchat/Embed.pm b/plugins/perl/lib/Xchat/Embed.pm deleted file mode 100644 index 6993dc6e..00000000 --- a/plugins/perl/lib/Xchat/Embed.pm +++ /dev/null @@ -1,325 +0,0 @@ -package Xchat::Embed; -use strict; -use warnings; -# list of loaded scripts keyed by their package names -# The package names are generated from the filename of the script using -# the file2pkg() function. -# The values of this hash are hash references with the following keys: -# filename -# The full path to the script. -# gui_entry -# This is hexchat_plugin pointer that is used to remove the script from -# Plugins and Scripts window when a script is unloaded. This has also -# been converted with the PTR2IV() macro. -# hooks -# This is an array of hooks that are associated with this script. -# These are pointers that have been converted with the PTR2IV() macro. -# inner_packages -# Other packages that are defined in a script. This is not recommended -# partly because these will also get removed when a script is unloaded. -# loaded_at -# A timestamp of when the script was loaded. The value is whatever -# Time::HiRes::time() returns. This is used to retain load order when -# using the RELOADALL command. -# shutdown -# This is either a code ref or undef. It will be executed just before a -# script is unloaded. -our %scripts; - -# This is a mapping of "inner package" => "containing script package" -our %owner_package; - -# used to keep track of which package a hook belongs to, if the normal way of -# checking which script is calling a hook function fails this will be used -# instead. When a hook is created this will be copied to the HookData structure -# and when a callback is invoked this it will be used to set this value. -our $current_package; - -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; - - # 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(); - - # this must be done before the error check so the unload will remove - # any inner packages defined by the script. if a script fails to load - # then any inner packages need to be removed as well. - my @inner_packages = $source =~ - m/^\s*package \s+ - ((?:[^\W:]+(?:::)?)+)\s*? # package name - # strict version number - (?:\d+(?:[.]\d+) # positive integer or decimal-fraction - |v\d+(?:[.]\d+){2,})? # dotted-decimal v-string - [{;] - /mgx; - - # check if any inner package defined in the to be loaded script has - # already been defined by another script - my @conflicts; - for my $inner ( @inner_packages ) { - if( exists $owner_package{ $inner } ) { - push @conflicts, $inner; - } - } - - # report conflicts and bail out - if( @conflicts ) { - my $error_message = - "'$file' won't be loaded due to conflicting inner packages:\n"; - for my $conflict_package ( @conflicts ) { - $error_message .= " $conflict_package already defined in " . - pkg_info($owner_package{ $conflict_package })->{filename}."\n"; - } - Xchat::print( $error_message ); - - return 2; - } - - 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/; - } - - $scripts{$package}{inner_packages} = [ @inner_packages ]; - @owner_package{ @inner_packages } = ($package) x @inner_packages; - _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} ); - } - - delete @owner_package{ @{$pkg_info->{inner_packages}} }; - for my $inner_package ( @{$pkg_info->{inner_packages}} ) { - Symbol::delete_package( $inner_package ); - } - 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( "configdir" ); - 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 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] !~ /(?:^IRC$|^Xchat)/; - $level++; - } - return; -} - -sub find_pkg { - my $level = 1; - - while( my ($package, $file, $line) = caller( $level ) ) { - return $package if $package =~ /^Xchat::Script::/; - $level++; - } - - my $current_package = get_current_package(); - if( defined $current_package ) { - return $current_package; - } - - my @frame = find_external_pkg(); - my $location; - - if( $frame[0] or $frame[1] ) { - my $calling_package = $frame[0]; - if( defined( my $owner = $owner_package{ $calling_package } ) ) { - return ($owner, $calling_package); - } - - $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"; - -} - -# convert function names into code references -sub fix_callback { - my ($package, $calling_package, $callback) = @_; - - unless( ref $callback ) { - unless( $callback =~ /::/ ) { - my $prefix = defined $calling_package ? $calling_package : $package; - $callback =~ s/^/${prefix}::/; - } - - no strict 'subs'; - $callback = \&{$callback}; - } - - return $callback; -} - -sub get_current_package { - return $current_package; -} - -sub set_current_package { - my $old_package = $current_package; - $current_package = shift; - - return $old_package; -} - -1 diff --git a/plugins/perl/lib/Xchat/List/Network.pm b/plugins/perl/lib/Xchat/List/Network.pm deleted file mode 100644 index 3a7e2ae6..00000000 --- a/plugins/perl/lib/Xchat/List/Network.pm +++ /dev/null @@ -1,33 +0,0 @@ -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( "configdir" ) . "/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 _; - - @servers = (); - 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; -} - -1 diff --git a/plugins/perl/lib/Xchat/List/Network/AutoJoin.pm b/plugins/perl/lib/Xchat/List/Network/AutoJoin.pm deleted file mode 100644 index 8b4e40d2..00000000 --- a/plugins/perl/lib/Xchat/List/Network/AutoJoin.pm +++ /dev/null @@ -1,80 +0,0 @@ -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 @autojoins; - - return bless \@autojoins, $class; -} - -sub add { - my $self = shift; - - my $line = shift; - - my ( $channel, $key ) = split /,/, $line, 2; - $key = $key || ''; - - push @$self, { - channel => $channel, - key => $key, - }; -} - -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 : ""; -} - -1 diff --git a/plugins/perl/lib/Xchat/List/Network/Entry.pm b/plugins/perl/lib/Xchat/List/Network/Entry.pm deleted file mode 100644 index 6f2aa925..00000000 --- a/plugins/perl/lib/Xchat/List/Network/Entry.pm +++ /dev/null @@ -1,106 +0,0 @@ -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; - - $entry->{ autojoins } = Xchat::List::Network::AutoJoin->new(); - - for my $field ( @fields ) { - SWITCH: for ( $field ) { - /^($letter_key_re)=(.*)/ && do { - $entry->{ $key_for{ $1 } } = $2; - last SWITCH; - }; - - /^J.(.*)/ && do { - $entry->{ autojoins }->add( $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 }; - } -} - -1 diff --git a/plugins/perl/perl.c b/plugins/perl/perl.c index af7865d7..79baff5a 100644 --- a/plugins/perl/perl.c +++ b/plugins/perl/perl.c @@ -323,11 +323,11 @@ array2av (char *array[]) return av; } -/* sets $Xchat::Embed::current_package */ +/* sets $HexChat::Embed::current_package */ static void set_current_package (SV *package) { - SV *current_package = get_sv ("Xchat::Embed::current_package", 1); + SV *current_package = get_sv ("HexChat::Embed::current_package", 1); SvSetSV_nosteal (current_package, package); } @@ -367,7 +367,7 @@ fd_cb (int fd, int flags, void *userdata) XPUSHs (sv_2mortal (newSViv (PTR2IV (data->hook)))); PUTBACK; - call_pv ("Xchat::unhook", G_EVAL); + call_pv ("HexChat::unhook", G_EVAL); SPAGAIN; SvREFCNT_dec (data->callback); @@ -429,7 +429,7 @@ timer_cb (void *userdata) XPUSHs (sv_mortalcopy (data->package)); PUTBACK; - call_pv ("Xchat::unhook", G_EVAL); + call_pv ("HexChat::unhook", G_EVAL); SPAGAIN; } } @@ -619,19 +619,19 @@ print_cb (char *word[], void *userdata) /* custom IRC perl functions for scripting */ -/* Xchat::Internal::register (scriptname, version, desc, shutdowncallback, filename) +/* HexChat::Internal::register (scriptname, version, desc, shutdowncallback, filename) * */ static -XS (XS_Xchat_register) +XS (XS_HexChat_register) { char *name, *version, *desc, *filename; void *gui_entry; dXSARGS; if (items != 4) { hexchat_printf (ph, - "Usage: Xchat::Internal::register(scriptname, version, desc, filename)"); + "Usage: HexChat::Internal::register(scriptname, version, desc, filename)"); } else { name = SvPV_nolen (ST (0)); version = SvPV_nolen (ST (1)); @@ -647,16 +647,16 @@ XS (XS_Xchat_register) } -/* Xchat::print(output) */ +/* HexChat::print(output) */ static -XS (XS_Xchat_print) +XS (XS_HexChat_print) { char *text = NULL; dXSARGS; if (items != 1) { - hexchat_print (ph, "Usage: Xchat::Internal::print(text)"); + hexchat_print (ph, "Usage: HexChat::Internal::print(text)"); } else { text = SvPV_nolen (ST (0)); hexchat_print (ph, text); @@ -665,7 +665,7 @@ XS (XS_Xchat_print) } static -XS (XS_Xchat_emit_print) +XS (XS_HexChat_emit_print) { char *event_name; int RETVAL; @@ -673,7 +673,7 @@ XS (XS_Xchat_emit_print) dXSARGS; if (items < 1) { - hexchat_print (ph, "Usage: Xchat::emit_print(event_name, ...)"); + hexchat_print (ph, "Usage: HexChat::emit_print(event_name, ...)"); } else { event_name = (char *) SvPV_nolen (ST (0)); RETVAL = 0; @@ -719,7 +719,7 @@ XS (XS_Xchat_emit_print) } static -XS (XS_Xchat_send_modes) +XS (XS_HexChat_send_modes) { AV *p_targets = NULL; int modes_per_line = 0; @@ -733,7 +733,7 @@ XS (XS_Xchat_send_modes) dXSARGS; if (items < 3 || items > 4) { hexchat_print (ph, - "Usage: Xchat::send_modes( targets, sign, mode, modes_per_line)" + "Usage: HexChat::send_modes( targets, sign, mode, modes_per_line)" ); } else { if (SvROK (ST (0))) { @@ -771,12 +771,12 @@ XS (XS_Xchat_send_modes) } } static -XS (XS_Xchat_get_info) +XS (XS_HexChat_get_info) { SV *temp = NULL; dXSARGS; if (items != 1) { - hexchat_print (ph, "Usage: Xchat::get_info(id)"); + hexchat_print (ph, "Usage: HexChat::get_info(id)"); } else { SV *id = ST (0); const char *RETVAL; @@ -810,13 +810,13 @@ XS (XS_Xchat_get_info) } static -XS (XS_Xchat_context_info) +XS (XS_HexChat_context_info) { const char *const *fields; dXSARGS; if (items > 0 ) { - hexchat_print (ph, "Usage: Xchat::Internal::context_info()"); + hexchat_print (ph, "Usage: HexChat::Internal::context_info()"); } fields = hexchat_list_fields (ph, "channels" ); XPUSHs (list_item_to_sv (NULL, fields)); @@ -824,14 +824,14 @@ XS (XS_Xchat_context_info) } static -XS (XS_Xchat_get_prefs) +XS (XS_HexChat_get_prefs) { const char *str; int integer; SV *temp = NULL; dXSARGS; if (items != 1) { - hexchat_print (ph, "Usage: Xchat::get_prefs(name)"); + hexchat_print (ph, "Usage: HexChat::get_prefs(name)"); } else { @@ -860,9 +860,9 @@ XS (XS_Xchat_get_prefs) } } -/* Xchat::Internal::hook_server(name, priority, callback, userdata) */ +/* HexChat::Internal::hook_server(name, priority, callback, userdata) */ static -XS (XS_Xchat_hook_server) +XS (XS_HexChat_hook_server) { char *name; @@ -877,7 +877,7 @@ XS (XS_Xchat_hook_server) if (items != 5) { hexchat_print (ph, - "Usage: Xchat::Internal::hook_server(name, priority, callback, userdata, package)"); + "Usage: HexChat::Internal::hook_server(name, priority, callback, userdata, package)"); } else { name = SvPV_nolen (ST (0)); pri = (int) SvIV (ST (1)); @@ -901,9 +901,9 @@ XS (XS_Xchat_hook_server) } } -/* Xchat::Internal::hook_command(name, priority, callback, help_text, userdata) */ +/* HexChat::Internal::hook_command(name, priority, callback, help_text, userdata) */ static -XS (XS_Xchat_hook_command) +XS (XS_HexChat_hook_command) { char *name; int pri; @@ -918,7 +918,7 @@ XS (XS_Xchat_hook_command) if (items != 6) { hexchat_print (ph, - "Usage: Xchat::Internal::hook_command(name, priority, callback, help_text, userdata, package)"); + "Usage: HexChat::Internal::hook_command(name, priority, callback, help_text, userdata, package)"); } else { name = SvPV_nolen (ST (0)); pri = (int) SvIV (ST (1)); @@ -950,9 +950,9 @@ XS (XS_Xchat_hook_command) } -/* Xchat::Internal::hook_print(name, priority, callback, [userdata]) */ +/* HexChat::Internal::hook_print(name, priority, callback, [userdata]) */ static -XS (XS_Xchat_hook_print) +XS (XS_HexChat_hook_print) { char *name; @@ -965,7 +965,7 @@ XS (XS_Xchat_hook_print) dXSARGS; if (items != 5) { hexchat_print (ph, - "Usage: Xchat::Internal::hook_print(name, priority, callback, userdata, package)"); + "Usage: HexChat::Internal::hook_print(name, priority, callback, userdata, package)"); } else { name = SvPV_nolen (ST (0)); pri = (int) SvIV (ST (1)); @@ -989,9 +989,9 @@ XS (XS_Xchat_hook_print) } } -/* Xchat::Internal::hook_timer(timeout, callback, userdata) */ +/* HexChat::Internal::hook_timer(timeout, callback, userdata) */ static -XS (XS_Xchat_hook_timer) +XS (XS_HexChat_hook_timer) { int timeout; SV *callback; @@ -1004,7 +1004,7 @@ XS (XS_Xchat_hook_timer) if (items != 4) { hexchat_print (ph, - "Usage: Xchat::Internal::hook_timer(timeout, callback, userdata, package)"); + "Usage: HexChat::Internal::hook_timer(timeout, callback, userdata, package)"); } else { timeout = (int) SvIV (ST (0)); callback = ST (1); @@ -1028,9 +1028,9 @@ XS (XS_Xchat_hook_timer) } } -/* Xchat::Internal::hook_fd(fd, callback, flags, userdata) */ +/* HexChat::Internal::hook_fd(fd, callback, flags, userdata) */ static -XS (XS_Xchat_hook_fd) +XS (XS_HexChat_hook_fd) { int fd; SV *callback; @@ -1044,7 +1044,7 @@ XS (XS_Xchat_hook_fd) if (items != 5) { hexchat_print (ph, - "Usage: Xchat::Internal::hook_fd(fd, callback, flags, userdata)"); + "Usage: HexChat::Internal::hook_fd(fd, callback, flags, userdata)"); } else { fd = (int) SvIV (ST (0)); callback = ST (1); @@ -1083,14 +1083,14 @@ XS (XS_Xchat_hook_fd) } static -XS (XS_Xchat_unhook) +XS (XS_HexChat_unhook) { hexchat_hook *hook; HookData *userdata; int retCount = 0; dXSARGS; if (items != 1) { - hexchat_print (ph, "Usage: Xchat::unhook(hook)"); + hexchat_print (ph, "Usage: HexChat::unhook(hook)"); } else { hook = INT2PTR (hexchat_hook *, SvUV (ST (0))); userdata = (HookData *) hexchat_unhook (ph, hook); @@ -1117,15 +1117,15 @@ XS (XS_Xchat_unhook) XSRETURN_EMPTY; } -/* Xchat::Internal::command(command) */ +/* HexChat::Internal::command(command) */ static -XS (XS_Xchat_command) +XS (XS_HexChat_command) { char *cmd = NULL; dXSARGS; if (items != 1) { - hexchat_print (ph, "Usage: Xchat::Internal::command(command)"); + hexchat_print (ph, "Usage: HexChat::Internal::command(command)"); } else { cmd = SvPV_nolen (ST (0)); hexchat_command (ph, cmd); @@ -1135,7 +1135,7 @@ XS (XS_Xchat_command) } static -XS (XS_Xchat_find_context) +XS (XS_HexChat_find_context) { char *server = NULL; char *chan = NULL; @@ -1143,7 +1143,7 @@ XS (XS_Xchat_find_context) dXSARGS; if (items > 2) - hexchat_print (ph, "Usage: Xchat::find_context ([channel, [server]])"); + hexchat_print (ph, "Usage: HexChat::find_context ([channel, [server]])"); { switch (items) { @@ -1191,23 +1191,23 @@ XS (XS_Xchat_find_context) } static -XS (XS_Xchat_get_context) +XS (XS_HexChat_get_context) { dXSARGS; if (items != 0) { - hexchat_print (ph, "Usage: Xchat::get_context()"); + hexchat_print (ph, "Usage: HexChat::get_context()"); } else { XSRETURN_IV (PTR2IV (hexchat_get_context (ph))); } } static -XS (XS_Xchat_set_context) +XS (XS_HexChat_set_context) { hexchat_context *ctx; dXSARGS; if (items != 1) { - hexchat_print (ph, "Usage: Xchat::set_context(ctx)"); + hexchat_print (ph, "Usage: HexChat::set_context(ctx)"); } else { ctx = INT2PTR (hexchat_context *, SvUV (ST (0))); XSRETURN_IV ((IV) hexchat_set_context (ph, ctx)); @@ -1215,11 +1215,11 @@ XS (XS_Xchat_set_context) } static -XS (XS_Xchat_nickcmp) +XS (XS_HexChat_nickcmp) { dXSARGS; if (items != 2) { - hexchat_print (ph, "Usage: Xchat::nickcmp(s1, s2)"); + hexchat_print (ph, "Usage: HexChat::nickcmp(s1, s2)"); } else { XSRETURN_IV ((IV) hexchat_nickcmp (ph, SvPV_nolen (ST (0)), SvPV_nolen (ST (1)))); @@ -1227,7 +1227,7 @@ XS (XS_Xchat_nickcmp) } static -XS (XS_Xchat_get_list) +XS (XS_HexChat_get_list) { SV *name; hexchat_list *list; @@ -1236,7 +1236,7 @@ XS (XS_Xchat_get_list) dXSARGS; if (items != 1) { - hexchat_print (ph, "Usage: Xchat::get_list(name)"); + hexchat_print (ph, "Usage: HexChat::get_list(name)"); } else { SP -= items; /*remove the argument list from the stack */ @@ -1268,12 +1268,12 @@ XS (XS_Xchat_get_list) } static -XS (XS_Xchat_Embed_plugingui_remove) +XS (XS_HexChat_Embed_plugingui_remove) { void *gui_entry; dXSARGS; if (items != 1) { - hexchat_print (ph, "Usage: Xchat::Embed::plugingui_remove(handle)"); + hexchat_print (ph, "Usage: HexChat::Embed::plugingui_remove(handle)"); } else { gui_entry = INT2PTR (void *, SvUV (ST (0))); hexchat_plugingui_remove (ph, gui_entry); @@ -1281,6 +1281,72 @@ XS (XS_Xchat_Embed_plugingui_remove) XSRETURN_EMPTY; } +static +XS (XS_HexChat_plugin_pref_set) +{ + dMARK; + dAX; + + XSRETURN_IV ((IV) hexchat_pluginpref_set_str (ph, SvPV_nolen (ST (0)), + SvPV_nolen (ST (1)))); +} + +static +XS (XS_HexChat_plugin_pref_get) +{ + int result; + char value[512]; + + dMARK; + dAX; + + result = hexchat_pluginpref_get_str (ph, SvPV_nolen (ST (0)), value); + + if (result) + XSRETURN_PV (value); + + XSRETURN_UNDEF; +} + +static +XS (XS_HexChat_plugin_pref_delete) +{ + dMARK; + dAX; + + XSRETURN_IV ((IV) hexchat_pluginpref_delete (ph, SvPV_nolen (ST (0)))); +} + +static +XS (XS_HexChat_plugin_pref_list) +{ + char list[4096]; + char value[512]; + char *token; + + dSP; + dMARK; + dAX; + + if (!hexchat_pluginpref_list (ph, list)) + XSRETURN_EMPTY; + + PUSHMARK (SP); + + token = strtok (list, ","); + while (token != NULL) + { + hexchat_pluginpref_get_str (ph, token, value); + + XPUSHs (sv_2mortal (newSVpv (token, 0))); + XPUSHs (sv_2mortal (newSVpv (value, 0))); + + token = strtok (NULL, ","); + } + + PUTBACK; +} + /* xs_init is the second argument perl_parse. As the name hints, it initializes XS subroutines (see the perlembed manpage) */ static void @@ -1292,31 +1358,36 @@ xs_init (pTHX) scripts by the 'use perlmod;' construction */ newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__); /* load up all the custom IRC perl functions */ - newXS ("Xchat::Internal::register", XS_Xchat_register, __FILE__); - newXS ("Xchat::Internal::hook_server", XS_Xchat_hook_server, __FILE__); - newXS ("Xchat::Internal::hook_command", XS_Xchat_hook_command, __FILE__); - newXS ("Xchat::Internal::hook_print", XS_Xchat_hook_print, __FILE__); - newXS ("Xchat::Internal::hook_timer", XS_Xchat_hook_timer, __FILE__); - newXS ("Xchat::Internal::hook_fd", XS_Xchat_hook_fd, __FILE__); - newXS ("Xchat::Internal::unhook", XS_Xchat_unhook, __FILE__); - newXS ("Xchat::Internal::print", XS_Xchat_print, __FILE__); - newXS ("Xchat::Internal::command", XS_Xchat_command, __FILE__); - newXS ("Xchat::Internal::set_context", XS_Xchat_set_context, __FILE__); - newXS ("Xchat::Internal::get_info", XS_Xchat_get_info, __FILE__); - newXS ("Xchat::Internal::context_info", XS_Xchat_context_info, __FILE__); - newXS ("Xchat::Internal::get_list", XS_Xchat_get_list, __FILE__); + newXS ("HexChat::Internal::register", XS_HexChat_register, __FILE__); + newXS ("HexChat::Internal::hook_server", XS_HexChat_hook_server, __FILE__); + newXS ("HexChat::Internal::hook_command", XS_HexChat_hook_command, __FILE__); + newXS ("HexChat::Internal::hook_print", XS_HexChat_hook_print, __FILE__); + newXS ("HexChat::Internal::hook_timer", XS_HexChat_hook_timer, __FILE__); + newXS ("HexChat::Internal::hook_fd", XS_HexChat_hook_fd, __FILE__); + newXS ("HexChat::Internal::unhook", XS_HexChat_unhook, __FILE__); + newXS ("HexChat::Internal::print", XS_HexChat_print, __FILE__); + newXS ("HexChat::Internal::command", XS_HexChat_command, __FILE__); + newXS ("HexChat::Internal::set_context", XS_HexChat_set_context, __FILE__); + newXS ("HexChat::Internal::get_info", XS_HexChat_get_info, __FILE__); + newXS ("HexChat::Internal::context_info", XS_HexChat_context_info, __FILE__); + newXS ("HexChat::Internal::get_list", XS_HexChat_get_list, __FILE__); + + newXS ("HexChat::Internal::plugin_pref_set", XS_HexChat_plugin_pref_set, __FILE__); + newXS ("HexChat::Internal::plugin_pref_get", XS_HexChat_plugin_pref_get, __FILE__); + newXS ("HexChat::Internal::plugin_pref_delete", XS_HexChat_plugin_pref_delete, __FILE__); + newXS ("HexChat::Internal::plugin_pref_list", XS_HexChat_plugin_pref_list, __FILE__); - newXS ("Xchat::find_context", XS_Xchat_find_context, __FILE__); - newXS ("Xchat::get_context", XS_Xchat_get_context, __FILE__); - newXS ("Xchat::get_prefs", XS_Xchat_get_prefs, __FILE__); - newXS ("Xchat::emit_print", XS_Xchat_emit_print, __FILE__); - newXS ("Xchat::send_modes", XS_Xchat_send_modes, __FILE__); - newXS ("Xchat::nickcmp", XS_Xchat_nickcmp, __FILE__); - - newXS ("Xchat::Embed::plugingui_remove", XS_Xchat_Embed_plugingui_remove, + newXS ("HexChat::find_context", XS_HexChat_find_context, __FILE__); + newXS ("HexChat::get_context", XS_HexChat_get_context, __FILE__); + newXS ("HexChat::get_prefs", XS_HexChat_get_prefs, __FILE__); + newXS ("HexChat::emit_print", XS_HexChat_emit_print, __FILE__); + newXS ("HexChat::send_modes", XS_HexChat_send_modes, __FILE__); + newXS ("HexChat::nickcmp", XS_HexChat_nickcmp, __FILE__); + + newXS ("HexChat::Embed::plugingui_remove", XS_HexChat_Embed_plugingui_remove, __FILE__); - stash = get_hv ("Xchat::", TRUE); + stash = get_hv ("HexChat::", TRUE); if (stash == NULL) { exit (1); } @@ -1328,7 +1399,8 @@ xs_init (pTHX) newCONSTSUB (stash, "PRI_LOWEST", newSViv (HEXCHAT_PRI_LOWEST)); newCONSTSUB (stash, "EAT_NONE", newSViv (HEXCHAT_EAT_NONE)); - newCONSTSUB (stash, "EAT_XCHAT", newSViv (HEXCHAT_EAT_HEXCHAT)); + newCONSTSUB (stash, "EAT_HEXCHAT", newSViv (HEXCHAT_EAT_HEXCHAT)); + newCONSTSUB (stash, "EAT_XCHAT", newSViv (HEXCHAT_EAT_HEXCHAT)); /* for compatibility */ newCONSTSUB (stash, "EAT_PLUGIN", newSViv (HEXCHAT_EAT_PLUGIN)); newCONSTSUB (stash, "EAT_ALL", newSViv (HEXCHAT_EAT_ALL)); newCONSTSUB (stash, "FD_READ", newSViv (HEXCHAT_FD_READ)); @@ -1338,7 +1410,7 @@ xs_init (pTHX) newCONSTSUB (stash, "KEEP", newSViv (1)); newCONSTSUB (stash, "REMOVE", newSViv (0)); - version = get_sv( "Xchat::VERSION", 1 ); + version = get_sv( "HexChat::VERSION", 1 ); sv_setpv( version, PACKAGE_VERSION ); } @@ -1352,7 +1424,7 @@ perl_init (void) static const char xchat_definitions[] = { /* Redefine the $SIG{__WARN__} handler to have HexChat printing warnings in the main window. (TheHobbit) */ -#include "xchat.pm.h" +#include "hexchat.pm.h" }; #ifdef OLD_PERL static const char irc_definitions[] = { @@ -1448,7 +1520,7 @@ perl_load_file (char *filename) perl_init (); } - return execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::load", 0)), + return execute_perl (sv_2mortal (newSVpv ("HexChat::Embed::load", 0)), filename); } @@ -1458,7 +1530,7 @@ perl_end (void) { if (my_perl != NULL) { - execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::unload_all", 0)), ""); + execute_perl (sv_2mortal (newSVpv ("HexChat::Embed::unload_all", 0)), ""); PL_perl_destruct_level = 1; perl_destruct (my_perl); perl_free (my_perl); @@ -1472,7 +1544,7 @@ static int perl_command_unloadall (char *word[], char *word_eol[], void *userdata) { if (my_perl != NULL) { - execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::unload_all", 0)), ""); + execute_perl (sv_2mortal (newSVpv ("HexChat::Embed::unload_all", 0)), ""); return HEXCHAT_EAT_HEXCHAT; } @@ -1483,7 +1555,7 @@ static int perl_command_reloadall (char *word[], char *word_eol[], void *userdata) { if (my_perl != NULL) { - execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::reload_all", 0)), ""); + execute_perl (sv_2mortal (newSVpv ("HexChat::Embed::reload_all", 0)), ""); return HEXCHAT_EAT_HEXCHAT; } else { @@ -1512,7 +1584,7 @@ perl_command_unload (char *word[], char *word_eol[], void *userdata) char *file = get_filename (word, word_eol); if (my_perl != NULL && file != NULL) { - execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::unload", 0)), file); + execute_perl (sv_2mortal (newSVpv ("HexChat::Embed::unload", 0)), file); return HEXCHAT_EAT_HEXCHAT; } @@ -1525,7 +1597,7 @@ perl_command_reload (char *word[], char *word_eol[], void *eat) char *file = get_filename (word, word_eol); if (my_perl != NULL && file != NULL) { - execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::reload", 0)), file); + execute_perl (sv_2mortal (newSVpv ("HexChat::Embed::reload", 0)), file); return HEXCHAT_EAT_HEXCHAT; } @@ -1535,6 +1607,15 @@ perl_command_reload (char *word[], char *word_eol[], void *eat) return HEXCHAT_EAT_NONE; } +static int +perl_command_eval (char *word[], char *word_eol[], void *userdata) +{ + if (my_perl != NULL) + execute_perl (sv_2mortal (newSVpv ("HexChat::Embed::evaluate", 0)), word_eol[2]); + + return HEXCHAT_EAT_HEXCHAT; +} + void hexchat_plugin_get_info (char **name, char **desc, char **version, void **reserved) @@ -1572,12 +1653,15 @@ hexchat_plugin_init (hexchat_plugin * plugin_handle, char **plugin_name, 0); hexchat_hook_command (ph, "reload", HEXCHAT_PRI_NORM, perl_command_reload, 0, 0); - hexchat_hook_command (ph, "pl_reload", HEXCHAT_PRI_NORM, perl_command_reload, 0, - (int*)1); + hexchat_hook_command (ph, "pl_reload", HEXCHAT_PRI_NORM, perl_command_reload, + "Reloads a Perl script. Syntax: /pl_reload ", (int*)1); hexchat_hook_command (ph, "unloadall", HEXCHAT_PRI_NORM, - perl_command_unloadall, 0, 0); + perl_command_unloadall, "Unloads all loaded Perl scripts.", 0); hexchat_hook_command (ph, "reloadall", HEXCHAT_PRI_NORM, - perl_command_reloadall, 0, 0); + perl_command_reloadall, "Realoads all loaded Perl scripts.", 0); + + hexchat_hook_command (ph, "pl", HEXCHAT_PRI_NORM, + perl_command_eval, "Evaluates Perl code. Syntax: /pl ", 0); /*perl_init (); */ hexchat_hook_timer (ph, 0, perl_auto_load, NULL ); diff --git a/plugins/perl/perl.vcxproj b/plugins/perl/perl.vcxproj index aa74c037..9d23ad58 100644 --- a/plugins/perl/perl.vcxproj +++ b/plugins/perl/perl.vcxproj @@ -81,7 +81,7 @@ move $(PerlLib).def "$(IntDir)" lib /nologo /machine:x86 "/def:$(IntDir)$(PerlLib).def" "/out:$(OutDir)\$(PerlLib).lib" "$(PerlPath)\bin\perl.exe" generate_header move irc.pm.h "$(IntDir)" -move xchat.pm.h "$(IntDir)" +move hexchat.pm.h "$(IntDir)" @@ -110,7 +110,7 @@ move $(PerlLib).def "$(IntDir)" lib /nologo /machine:x64 "/def:$(IntDir)$(PerlLib).def" "/out:$(OutDir)\$(PerlLib).lib" "$(PerlPath)\bin\perl.exe" generate_header move irc.pm.h "$(IntDir)" -move xchat.pm.h "$(IntDir)" +move hexchat.pm.h "$(IntDir)" -- cgit 1.4.1