c.sexchat/plugins/perl/lib/Xchat/Embed.pm

254 lines
5.4 KiB
Perl

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