Update XChat to r1514

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;

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

plugins/perl/perl.c

@@ -317,6 +317,14 @@ array2av (char *array[])
 	return av;
 }
 
+/* sets $Xchat::Embed::current_package */
+static void
+set_current_package (SV *package)
+{
+	SV *current_package = get_sv ("Xchat::Embed::current_package", 1);
+	SvSetSV_nosteal (current_package, package);
+}
+
 static int
 fd_cb (int fd, int flags, void *userdata)
 {
@@ -332,7 +340,9 @@ fd_cb (int fd, int flags, void *userdata)
 	XPUSHs (data->userdata);
 	PUTBACK;
 
+	set_current_package (data->package);
 	count = call_sv (data->callback, G_EVAL);
+	set_current_package (&PL_sv_undef);
 	SPAGAIN;
 
 	if (SvTRUE (ERRSV)) {
@@ -390,7 +400,10 @@ timer_cb (void *userdata)
 	if (data->ctx) {
 		xchat_set_context (ph, data->ctx);
 	}
+
+	set_current_package (data->package);
 	count = call_sv (data->callback, G_EVAL);
+	set_current_package (&PL_sv_undef);
 	SPAGAIN;
 
 	if (SvTRUE (ERRSV)) {
@@ -447,7 +460,9 @@ server_cb (char *word[], char *word_eol[], void *userdata)
 	PUTBACK;
 
 	data->depth++;
+	set_current_package (data->package);
 	count = call_sv (data->callback, G_EVAL);
+	set_current_package (&PL_sv_undef);
 	data->depth--;
 	SPAGAIN;
 	if (SvTRUE (ERRSV)) {
@@ -494,7 +509,9 @@ command_cb (char *word[], char *word_eol[], void *userdata)
 	PUTBACK;
 
 	data->depth++;
+	set_current_package (data->package);
 	count = call_sv (data->callback, G_EVAL);
+	set_current_package (&PL_sv_undef);
 	data->depth--;
 	SPAGAIN;
 	if (SvTRUE (ERRSV)) {
@@ -568,7 +585,9 @@ print_cb (char *word[], void *userdata)
 	PUTBACK;
 
 	data->depth++;
+	set_current_package (data->package);
 	count = call_sv (data->callback, G_EVAL);
+	set_current_package (&PL_sv_undef);
 	data->depth--;
 	SPAGAIN;
 	if (SvTRUE (ERRSV)) {
@@ -843,31 +862,32 @@ XS (XS_Xchat_hook_server)
 	int pri;
 	SV *callback;
 	SV *userdata;
+	SV *package;
 	xchat_hook *hook;
 	HookData *data;
 
 	dXSARGS;
 
-	if (items != 4) {
+	if (items != 5) {
 		xchat_print (ph,
-						 "Usage: Xchat::Internal::hook_server(name, priority, callback, userdata)");
+						 "Usage: Xchat::Internal::hook_server(name, priority, callback, userdata, package)");
 	} else {
 		name = SvPV_nolen (ST (0));
 		pri = (int) SvIV (ST (1));
 		callback = ST (2);
 		userdata = ST (3);
+		package = ST (4);
 		data = NULL;
 		data = malloc (sizeof (HookData));
 		if (data == NULL) {
 			XSRETURN_UNDEF;
 		}
 
-		data->callback = sv_mortalcopy (callback);
-		SvREFCNT_inc (data->callback);
-		data->userdata = sv_mortalcopy (userdata);
-		SvREFCNT_inc (data->userdata);
+		data->callback = newSVsv (callback);
+		data->userdata = newSVsv (userdata);
 		data->depth = 0;
-		data->package = NULL;
+		data->package = newSVsv (package);
+
 		hook = xchat_hook_server (ph, name, pri, server_cb, data);
 
 		XSRETURN_IV (PTR2IV (hook));
@@ -883,26 +903,28 @@ XS (XS_Xchat_hook_command)
 	SV *callback;
 	char *help_text = NULL;
 	SV *userdata;
+	SV *package;
 	xchat_hook *hook;
 	HookData *data;
 
 	dXSARGS;
 
-	if (items != 5) {
+	if (items != 6) {
 		xchat_print (ph,
-						 "Usage: Xchat::Internal::hook_command(name, priority, callback, help_text, userdata)");
+						 "Usage: Xchat::Internal::hook_command(name, priority, callback, help_text, userdata, package)");
 	} else {
 		name = SvPV_nolen (ST (0));
 		pri = (int) SvIV (ST (1));
 		callback = ST (2);
 
-		/* leave the help text has NULL if the help text is undefined to avoid
+		/* leave the help text as NULL if the help text is undefined to avoid
 		 * overriding the default help message for builtin commands */
 		if (SvOK(ST (3))) {
 			help_text = SvPV_nolen (ST (3));
 		}
 
 		userdata = ST (4);
+		package = ST (5);
 		data = NULL;
 
 		data = malloc (sizeof (HookData));
@@ -910,12 +932,10 @@ XS (XS_Xchat_hook_command)
 			XSRETURN_UNDEF;
 		}
 
-		data->callback = sv_mortalcopy (callback);
-		SvREFCNT_inc (data->callback);
-		data->userdata = sv_mortalcopy (userdata);
-		SvREFCNT_inc (data->userdata);
+		data->callback = newSVsv (callback);
+		data->userdata = newSVsv (userdata);
 		data->depth = 0;
-		data->package = NULL;
+		data->package = newSVsv (package);
 		hook = xchat_hook_command (ph, name, pri, command_cb, help_text, data);
 
 		XSRETURN_IV (PTR2IV (hook));
@@ -932,30 +952,30 @@ XS (XS_Xchat_hook_print)
 	int pri;
 	SV *callback;
 	SV *userdata;
+	SV *package;
 	xchat_hook *hook;
 	HookData *data;
 	dXSARGS;
-	if (items != 4) {
+	if (items != 5) {
 		xchat_print (ph,
-						 "Usage: Xchat::Internal::hook_print(name, priority, callback, userdata)");
+						 "Usage: Xchat::Internal::hook_print(name, priority, callback, userdata, package)");
 	} else {
 		name = SvPV_nolen (ST (0));
 		pri = (int) SvIV (ST (1));
 		callback = ST (2);
 		data = NULL;
 		userdata = ST (3);
+		package = ST (4);
 
 		data = malloc (sizeof (HookData));
 		if (data == NULL) {
 			XSRETURN_UNDEF;
 		}
 
-		data->callback = sv_mortalcopy (callback);
-		SvREFCNT_inc (data->callback);
-		data->userdata = sv_mortalcopy (userdata);
-		SvREFCNT_inc (data->userdata);
+		data->callback = newSVsv (callback);
+		data->userdata = newSVsv (userdata);
 		data->depth = 0;
-		data->package = NULL;
+		data->package = newSVsv (package);
 		hook = xchat_hook_print (ph, name, pri, print_cb, data);
 
 		XSRETURN_IV (PTR2IV (hook));
@@ -990,13 +1010,10 @@ XS (XS_Xchat_hook_timer)
 			XSRETURN_UNDEF;
 		}
 
-		data->callback = sv_mortalcopy (callback);
-		SvREFCNT_inc (data->callback);
-		data->userdata = sv_mortalcopy (userdata);
-		SvREFCNT_inc (data->userdata);
+		data->callback = newSVsv (callback);
+		data->userdata = newSVsv (userdata);
 		data->ctx = xchat_get_context (ph);
-		data->package = sv_mortalcopy (package);
-		SvREFCNT_inc (data->package);
+		data->package = newSVsv (package);
 		hook = xchat_hook_timer (ph, timeout, timer_cb, data);
 		data->hook = hook;
 
@@ -1012,6 +1029,7 @@ XS (XS_Xchat_hook_fd)
 	SV *callback;
 	int flags;
 	SV *userdata;
+	SV *package;
 	xchat_hook *hook;
 	HookData *data;
 
@@ -1025,6 +1043,7 @@ XS (XS_Xchat_hook_fd)
 		callback = ST (1);
 		flags = (int) SvIV (ST (2));
 		userdata = ST (3);
+		package = ST (4);
 		data = NULL;
 
 #ifdef WIN32
@@ -1045,11 +1064,10 @@ XS (XS_Xchat_hook_fd)
 			XSRETURN_UNDEF;
 		}
 
-		data->callback = sv_mortalcopy (callback);
-		SvREFCNT_inc (data->callback);
-		data->userdata = sv_mortalcopy (userdata);
-		SvREFCNT_inc (data->userdata);
-		data->package = NULL;
+		data->callback = newSVsv (callback);
+		data->userdata = newSVsv (userdata);
+		data->depth = 0;
+		data->package = newSVsv (package);
 		hook = xchat_hook_fd (ph, fd, flags, fd_cb, data);
 		data->hook = hook;
 
@@ -1084,6 +1102,7 @@ XS (XS_Xchat_unhook)
 			if (userdata->package != NULL) {
 				SvREFCNT_dec (userdata->package);
 			}
+
 			free (userdata);
 		}
 		XSRETURN (retCount);