add xchat r1489
This commit is contained in:
berkeviktor@aol.com
253
plugins/perl/lib/Xchat/Embed.pm
Normal file
253
plugins/perl/lib/Xchat/Embed.pm
Normal file
@ -0,0 +1,253 @@
|
||||
package Xchat::Embed;
|
||||
use strict;
|
||||
use warnings;
|
||||
# list of loaded scripts keyed by their package names
|
||||
our %scripts;
|
||||
|
||||
sub load {
|
||||
my $file = expand_homedir( shift @_ );
|
||||
my $package = file2pkg( $file );
|
||||
|
||||
if( exists $scripts{$package} ) {
|
||||
my $pkg_info = pkg_info( $package );
|
||||
my $filename = File::Basename::basename( $pkg_info->{filename} );
|
||||
Xchat::printf(
|
||||
qq{'%s' already loaded from '%s'.\n},
|
||||
$filename, $pkg_info->{filename}
|
||||
);
|
||||
Xchat::print(
|
||||
'If this is a different script then it rename and try '.
|
||||
'loading it again.'
|
||||
);
|
||||
return 2;
|
||||
}
|
||||
|
||||
if( open my $source_handle, $file ) {
|
||||
my $source = do {local $/; <$source_handle>};
|
||||
close $source_handle;
|
||||
# we shouldn't care about things after __END__
|
||||
$source =~ s/^__END__.*//ms;
|
||||
|
||||
if(
|
||||
my @replacements = $source =~
|
||||
m/^\s*package ((?:[^\W:]+(?:::)?)+)\s*?;/mg
|
||||
) {
|
||||
|
||||
if ( @replacements > 1 ) {
|
||||
Xchat::print(
|
||||
"Too many package defintions, only 1 is allowed\n"
|
||||
);
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $original_package = shift @replacements;
|
||||
|
||||
# remove original package declaration
|
||||
$source =~ s/^(package $original_package\s*;)/#$1/m;
|
||||
|
||||
# fixes things up for code calling subs with fully qualified names
|
||||
$source =~ s/${original_package}:://g;
|
||||
}
|
||||
|
||||
# this must come before the eval or the filename will not be found in
|
||||
# Xchat::register
|
||||
$scripts{$package}{filename} = $file;
|
||||
$scripts{$package}{loaded_at} = Time::HiRes::time();
|
||||
|
||||
my $full_path = File::Spec->rel2abs( $file );
|
||||
$source =~ s/^/#line 1 "$full_path"\n\x7Bpackage $package;/;
|
||||
|
||||
# make sure we add the closing } even if the last line is a comment
|
||||
if( $source =~ /^#.*\Z/m ) {
|
||||
$source =~ s/^(?=#.*\Z)/\x7D/m;
|
||||
} else {
|
||||
$source =~ s/\Z/\x7D/;
|
||||
}
|
||||
|
||||
_do_eval( $source );
|
||||
|
||||
unless( exists $scripts{$package}{gui_entry} ) {
|
||||
$scripts{$package}{gui_entry} =
|
||||
Xchat::Internal::register(
|
||||
"", "unknown", "", $file
|
||||
);
|
||||
}
|
||||
|
||||
if( $@ ) {
|
||||
# something went wrong
|
||||
$@ =~ s/\(eval \d+\)/$file/g;
|
||||
Xchat::print( "Error loading '$file':\n$@\n" );
|
||||
# make sure the script list doesn't contain false information
|
||||
unload( $scripts{$package}{filename} );
|
||||
return 1;
|
||||
}
|
||||
} else {
|
||||
Xchat::print( "Error opening '$file': $!\n" );
|
||||
return 2;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _do_eval {
|
||||
no strict;
|
||||
no warnings;
|
||||
eval $_[0];
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $file = shift @_;
|
||||
my $package = file2pkg( $file );
|
||||
my $pkg_info = pkg_info( $package );
|
||||
|
||||
if( $pkg_info ) {
|
||||
# take care of the shutdown callback
|
||||
if( exists $pkg_info->{shutdown} ) {
|
||||
# allow incorrectly written scripts to be unloaded
|
||||
eval {
|
||||
if( ref $pkg_info->{shutdown} eq 'CODE' ) {
|
||||
$pkg_info->{shutdown}->();
|
||||
} elsif ( $pkg_info->{shutdown} ) {
|
||||
no strict 'refs';
|
||||
&{$pkg_info->{shutdown}};
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
if( exists $pkg_info->{hooks} ) {
|
||||
for my $hook ( @{$pkg_info->{hooks}} ) {
|
||||
Xchat::unhook( $hook, $package );
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if( exists $pkg_info->{gui_entry} ) {
|
||||
plugingui_remove( $pkg_info->{gui_entry} );
|
||||
}
|
||||
|
||||
Symbol::delete_package( $package );
|
||||
delete $scripts{$package};
|
||||
return Xchat::EAT_ALL;
|
||||
} else {
|
||||
Xchat::print( qq{"$file" is not loaded.\n} );
|
||||
return Xchat::EAT_NONE;
|
||||
}
|
||||
}
|
||||
|
||||
sub unload_all {
|
||||
for my $package ( keys %scripts ) {
|
||||
unload( $scripts{$package}->{filename} );
|
||||
}
|
||||
|
||||
return Xchat::EAT_ALL;
|
||||
}
|
||||
|
||||
sub reload {
|
||||
my $file = shift @_;
|
||||
my $package = file2pkg( $file );
|
||||
my $pkg_info = pkg_info( $package );
|
||||
my $fullpath = $file;
|
||||
|
||||
if( $pkg_info ) {
|
||||
$fullpath = $pkg_info->{filename};
|
||||
unload( $file );
|
||||
}
|
||||
|
||||
load( $fullpath );
|
||||
return Xchat::EAT_ALL;
|
||||
}
|
||||
|
||||
sub reload_all {
|
||||
my @dirs = Xchat::get_info( "xchatdirfs" ) || Xchat::get_info( "xchatdir" );
|
||||
push @dirs, File::Spec->catdir( $dirs[0], "plugins" );
|
||||
for my $dir ( @dirs ) {
|
||||
my $auto_load_glob = File::Spec->catfile( $dir, "*.pl" );
|
||||
my @scripts = map { $_->{filename} }
|
||||
sort { $a->{loaded_at} <=> $b->{loaded_at} } values %scripts;
|
||||
push @scripts, File::Glob::bsd_glob( $auto_load_glob );
|
||||
|
||||
my %seen;
|
||||
@scripts = grep { !$seen{ $_ }++ } @scripts;
|
||||
|
||||
unload_all();
|
||||
for my $script ( @scripts ) {
|
||||
if( !pkg_info( file2pkg( $script ) ) ) {
|
||||
load( $script );
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub expand_homedir {
|
||||
my $file = shift @_;
|
||||
|
||||
if ( $^O eq "MSWin32" ) {
|
||||
$file =~ s/^~/$ENV{USERPROFILE}/;
|
||||
} else {
|
||||
$file =~ s{^~}{
|
||||
(getpwuid($>))[7] || $ENV{HOME} || $ENV{LOGDIR}
|
||||
}ex;
|
||||
}
|
||||
return $file;
|
||||
}
|
||||
|
||||
sub file2pkg {
|
||||
my $string = File::Basename::basename( shift @_ );
|
||||
$string =~ s/\.pl$//i;
|
||||
$string =~ s|([^A-Za-z0-9/])|'_'.unpack("H*",$1)|eg;
|
||||
return "Xchat::Script::" . $string;
|
||||
}
|
||||
|
||||
sub pkg_info {
|
||||
my $package = shift @_;
|
||||
return $scripts{$package};
|
||||
}
|
||||
|
||||
sub find_external_pkg {
|
||||
my $level = 1;
|
||||
|
||||
while( my @frame = caller( $level ) ) {
|
||||
return @frame if $frame[0] !~ /^Xchat/;
|
||||
$level++;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub find_pkg {
|
||||
my $level = 1;
|
||||
|
||||
while( my ($package, $file, $line) = caller( $level ) ) {
|
||||
return $package if $package =~ /^Xchat::Script::/;
|
||||
$level++;
|
||||
}
|
||||
|
||||
my @frame = find_external_pkg();
|
||||
my $location;
|
||||
|
||||
if( $frame[0] or $frame[1] ) {
|
||||
$location = $frame[1] ? $frame[1] : "package $frame[0]";
|
||||
$location .= " line $frame[2]";
|
||||
} else {
|
||||
$location = "unknown location";
|
||||
}
|
||||
|
||||
die "Unable to determine which script this hook belongs to. at $location\n";
|
||||
|
||||
}
|
||||
|
||||
sub fix_callback {
|
||||
my ($package, $callback) = @_;
|
||||
|
||||
unless( ref $callback ) {
|
||||
# change the package to the correct one in case it was hardcoded
|
||||
$callback =~ s/^.*:://;
|
||||
$callback = qq[${package}::$callback];
|
||||
|
||||
no strict 'subs';
|
||||
$callback = \&{$callback};
|
||||
}
|
||||
|
||||
return $callback;
|
||||
}
|
||||
|
||||
1
|
||||
Reference in New Issue
Block a user