diff options
Diffstat (limited to 'plugins/perl/lib')
| -rw-r--r-- | plugins/perl/lib/Xchat.pm | 15 | ||||
| -rw-r--r-- | plugins/perl/lib/Xchat/Embed.pm | 122 |
2 files changed, 100 insertions, 37 deletions
diff --git a/plugins/perl/lib/Xchat.pm b/plugins/perl/lib/Xchat.pm index 1849789b..cb1dc3d6 100644 --- a/plugins/perl/lib/Xchat.pm +++ b/plugins/perl/lib/Xchat.pm @@ -1,7 +1,3 @@ -BEGIN { - $INC{'Xchat.pm'} = 'DUMMY'; -} - $SIG{__WARN__} = sub { my $message = shift @_; my ($package) = caller; @@ -141,7 +137,7 @@ sub hook_server { my $pkg_info = Xchat::Embed::pkg_info( $package ); my $hook = Xchat::Internal::hook_server( - $message, $priority, $callback, $data + $message, $priority, $callback, $data, $package ); push @{$pkg_info->{hooks}}, $hook if defined $hook; return $hook; @@ -165,7 +161,7 @@ sub hook_command { my $pkg_info = Xchat::Embed::pkg_info( $package ); my $hook = Xchat::Internal::hook_command( - $command, $priority, $callback, $help_text, $data + $command, $priority, $callback, $help_text, $data, $package ); push @{$pkg_info->{hooks}}, $hook if defined $hook; return $hook; @@ -242,7 +238,7 @@ sub hook_print { my $pkg_info = Xchat::Embed::pkg_info( $package ); my $hook = Xchat::Internal::hook_print( - $event, $priority, $callback, $data + $event, $priority, $callback, $data, $package ); push @{$pkg_info->{hooks}}, $hook if defined $hook; return $hook; @@ -276,7 +272,7 @@ sub hook_fd { my $fileno = fileno $fd; return undef unless defined $fileno; # no underlying fd for this handle - my ($package) = Xchat::Embed::find_pkg(); + my $package = Xchat::Embed::find_pkg(); $callback = Xchat::Embed::fix_callback( $package, $callback ); my ($flags, $data) = (Xchat::FD_READ, undef); @@ -297,7 +293,8 @@ sub hook_fd { 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; diff --git a/plugins/perl/lib/Xchat/Embed.pm b/plugins/perl/lib/Xchat/Embed.pm index dffbaf5e..1b779f80 100644 --- a/plugins/perl/lib/Xchat/Embed.pm +++ b/plugins/perl/lib/Xchat/Embed.pm @@ -2,8 +2,39 @@ 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 xchat_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 ); @@ -28,32 +59,45 @@ sub load { # 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(); + # 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;/; @@ -64,6 +108,8 @@ sub load { $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} ) { @@ -72,7 +118,7 @@ sub load { "", "unknown", "", $file ); } - + if( $@ ) { # something went wrong $@ =~ s/\(eval \d+\)/$file/g; @@ -120,11 +166,14 @@ sub unload { } } - 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; @@ -207,7 +256,7 @@ sub find_external_pkg { my $level = 1; while( my @frame = caller( $level ) ) { - return @frame if $frame[0] !~ /^Xchat/; + return @frame if $frame[0] !~ /(?:^IRC$|^Xchat)/; $level++; } @@ -221,10 +270,20 @@ sub find_pkg { $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; + } + $location = $frame[1] ? $frame[1] : "package $frame[0]"; $location .= " line $frame[2]"; } else { @@ -239,10 +298,6 @@ 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}; } @@ -250,4 +305,15 @@ sub fix_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 |