update perl extension bindings. This pretty much works now

This commit is contained in:
Fish 2005-09-28 13:41:42 +00:00
parent 68c8621998
commit 6a22f33a2e
3 changed files with 196 additions and 5 deletions

View file

@ -50,6 +50,11 @@ use Symbol();
my ($package) = caller;
my $pkg_info = NeoStats::Embed::pkg_info( $package );
my $filename = $pkg_info->{filename};
if ($pkg_info->{type} != 0) {
NeoStats::debug("Extension tried to register as a module");
return NeoStats::NS_FAILURE;
}
my ($name, $version, $description, $startupcb, $shutdowncb) = @_;
$description = "" unless defined $description;
@ -69,6 +74,33 @@ use Symbol();
return NeoStats::NS_SUCCESS;
}
sub registerextension {
if (@_ != 4) {
NeoStats::debug("Invalid Number of arguments to registerextension");
return NeoStats::NS_FAILURE;
}
my ($package) = caller;
my $pkg_info = NeoStats::Embed::pkg_info( $package );
my $filename = $pkg_info->{filename};
if ($pkg_info->{type} != 1) {
NeoStats::debug("Perl Module tried to register as a extension");
return NeoStats::NS_FAILURE;
}
my ($name, $version, $startupcb, $shutdowncb) = @_;
$pkg_info->{name} = $name;
$pkg_info->{version} = $version;
$pkg_info->{gui_entry} =
NeoStats::Internal::registerextension( $pkg_info->{name}, $pkg_info->{version});
$startupcb = NeoStats::Embed::fix_callback( $package, $startupcb );
$shutdowncb = NeoStats::Embed::fix_callback( $package, $shutdowncb );
$pkg_info->{shutdown} = $shutdowncb;
$pkg_info->{startup} = $startupcb;
# keep with old behavior
return NeoStats::NS_SUCCESS;
}
sub hook_event {
@ -719,6 +751,7 @@ $SIG{__WARN__} = sub {
# this must come before the eval or the filename will not be found in
# NeoStats::register
$scripts{$package}{filename} = $file;
$scripts{$package}{type} = 0;
{
# no strict; no warnings;
@ -741,7 +774,57 @@ $SIG{__WARN__} = sub {
return 0;
}
sub loadextension {
my $file = expand_homedir( shift @_ );
my $package = file2pkg( $file );
if ( open FH, $file ) {
my $source = do {local $/; <FH>};
close FH;
if ( my $replacements = $source =~ s/^\s*package ([\w:]+).*?;//mg ) {
my $original_package = $1;
if ( $replacements > 1 ) {
NeoStats::debug( "Too many package defintions, only 1 is allowed\n" );
return 1;
}
# 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
# NeoStats::registerextension
$scripts{$package}{filename} = $file;
$scripts{$package}{type} = 1;
{
# no strict; no warnings;
eval "package $package; $source;";
}
if ( $@ ) {
# something went wrong
NeoStats::debug( "Error loading extension '$file':\n$@\n" );
# make sure the script list doesn't contain false information
unload( $scripts{$package}{filename} );
return 1;
}
} else {
NeoStats::debug( "Error opening '$file': $!\n" );
return 2;
}
return 0;
}
sub unload {
my $file = shift @_;
my $package = file2pkg( $file );

View file

@ -51,6 +51,11 @@
"my $pkg_info = NeoStats::Embed::pkg_info( $package );\n"
"my $filename = $pkg_info->{filename};\n"
"\n"
"if ($pkg_info->{type} != 0) {\n"
"NeoStats::debug(\"Extension tried to register as a module\");\n"
"return NeoStats::NS_FAILURE;\n"
"}\n"
"\n"
"my ($name, $version, $description, $startupcb, $shutdowncb) = @_;\n"
"$description = \"\" unless defined $description;\n"
"\n"
@ -69,6 +74,33 @@
"return NeoStats::NS_SUCCESS;\n"
"}\n"
"\n"
"sub registerextension {\n"
"if (@_ != 4) {\n"
"NeoStats::debug(\"Invalid Number of arguments to registerextension\");\n"
"return NeoStats::NS_FAILURE;\n"
"}\n"
"my ($package) = caller;\n"
"my $pkg_info = NeoStats::Embed::pkg_info( $package );\n"
"my $filename = $pkg_info->{filename};\n"
"\n"
"if ($pkg_info->{type} != 1) {\n"
"NeoStats::debug(\"Perl Module tried to register as a extension\");\n"
"return NeoStats::NS_FAILURE;\n"
"}\n"
"\n"
"my ($name, $version, $startupcb, $shutdowncb) = @_;\n"
"$pkg_info->{name} = $name;\n"
"$pkg_info->{version} = $version;\n"
"$pkg_info->{gui_entry} =\n"
"NeoStats::Internal::registerextension( $pkg_info->{name}, $pkg_info->{version});\n"
"$startupcb = NeoStats::Embed::fix_callback( $package, $startupcb );\n"
"$shutdowncb = NeoStats::Embed::fix_callback( $package, $shutdowncb );\n"
"$pkg_info->{shutdown} = $shutdowncb;\n"
"$pkg_info->{startup} = $startupcb;\n"
"\n"
"\n"
"return NeoStats::NS_SUCCESS;\n"
"}\n"
"\n"
"\n"
"sub hook_event {\n"
@ -719,6 +751,7 @@
"\n"
"\n"
"$scripts{$package}{filename} = $file;\n"
"$scripts{$package}{type} = 0;\n"
"\n"
"{\n"
"\n"
@ -742,6 +775,56 @@
"return 0;\n"
"}\n"
"\n"
"\n"
"sub loadextension {\n"
"my $file = expand_homedir( shift @_ );\n"
"\n"
"my $package = file2pkg( $file );\n"
"\n"
"if ( open FH, $file ) {\n"
"my $source = do {local $/; <FH>};\n"
"close FH;\n"
"\n"
"if ( my $replacements = $source =~ s/^\\s*package ([\\w:]+).*?;//mg ) {\n"
"my $original_package = $1;\n"
"\n"
"if ( $replacements > 1 ) {\n"
"NeoStats::debug( \"Too many package defintions, only 1 is allowed\\n\" );\n"
"return 1;\n"
"}\n"
"\n"
"\n"
"$source =~ s/${original_package}:://g;\n"
"\n"
"}\n"
"\n"
"\n"
"\n"
"$scripts{$package}{filename} = $file;\n"
"$scripts{$package}{type} = 1;\n"
"\n"
"{\n"
"\n"
"eval \"package $package; $source;\";\n"
"}\n"
"\n"
"if ( $@ ) {\n"
"\n"
"NeoStats::debug( \"Error loading extension '$file':\\n$@\\n\" );\n"
"\n"
"\n"
"unload( $scripts{$package}{filename} );\n"
"return 1;\n"
"}\n"
"\n"
"} else {\n"
"NeoStats::debug( \"Error opening '$file': $!\\n\" );\n"
"return 2;\n"
"}\n"
"\n"
"return 0;\n"
"}\n"
"\n"
"sub unload {\n"
"my $file = shift @_;\n"
"my $package = file2pkg( $file );\n"

View file

@ -433,11 +433,33 @@ XS (XS_NeoStats_register)
mod->info->version = strndup(SvPV_nolen (ST (1)), sv_len(ST (1)));
mod->info->description = strndup(SvPV_nolen (ST (2)), sv_len(ST(2)));
mod->pm->registered = 1;
mod->pm->type = TYPE_MODULE;
XSRETURN_UV (PTR2UV (mod));
}
}
static
XS (XS_NeoStats_registerextension)
{
Module *mod;
dXSARGS;
if (items != 2) {
nlog(LOG_WARNING, "Usage: NeoStats::Internal::registerextension(scriptname, version)");
} else {
mod = GET_CUR_MODULE();
if (!mod) {
nlog(LOG_WARNING, "Current Mod Stack for Perl Mods is screwed");
XSRETURN_EMPTY;
}
mod->pm->extname = strndup(SvPV_nolen(ST(0)), sv_len(ST (0)));
mod->pm->extversion = strndup(SvPV_nolen (ST (1)), sv_len(ST (1)));
mod->pm->registered = 1;
mod->pm->type = TYPE_EXTENSION;
XSRETURN_UV (PTR2UV (mod));
}
}
/* NeoStats::debug(output) */
static
XS (XS_NeoStats_debug)
@ -1535,6 +1557,7 @@ xs_init (pTHX)
newCONSTSUB (stash, "NS_FAILURE", newSViv (NS_FAILURE));
if (mod->pm->extninit) {
newXS ("NeoStats::Internal::registerextension", XS_NeoStats_registerextension, __FILE__);
mod->pm->extninit();
}
}
@ -1595,27 +1618,29 @@ Module *load_perlfiles (const char *filename, Module *mod, perl_xs_init init_fun
int load_perlextension(const char *filename, perl_xs_init init_func, Client *u)
{
Module *mod;
char filebuf[BUFSIZE];
mod = GET_CUR_MODULE();
if (!mod) {
nlog(LOG_WARNING, "Trying to laod a Perl Extension %s in the core? No No", filename);
return NS_FAILURE;
}
mod = load_perlfiles((const char *)filename, mod, init_func);
ircsnprintf(filebuf, BUFSIZE, "modules/%s.ple", filename);
printf("%s\n",filebuf);
mod = load_perlfiles((const char *)filebuf, mod, init_func);
SET_RUN_LEVEL(mod);
if (!execute_perl (mod, sv_2mortal (newSVpv ("NeoStats::Embed::loadextension", 0)),
1, (char *)filename)) {
1, (char *)filebuf)) {
/* if we are here, check that pm->mod->description has something, otherwise the script didnt register */
if (!mod->pm->registered) {
load_module_error(u, filename, __("Perl extension didn't register.", u));
load_module_error(u, filebuf, __("Perl extension didn't register.", u));
unload_perlextension(mod);
return NS_FAILURE;
}
/* it loaded ok */
} else {
load_module_error(u, filename, __("Errors in Perl extension", u));
load_module_error(u, filebuf, __("Errors in Perl extension", u));
unload_perlextension(mod);
return NS_FAILURE;
}