Update XChat to r1514

1 files changed, 94 insertions, 28 deletions

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