[NeoStats-Devel] [Commits] r2643 - in trunk: . doc src
[email protected] Wed, 6 Jul 2005 23:28:47 +1000
Newsgroups
gmane.comp.neostats.devel
Message-ID
<[email protected] >
Author: Fish
Date: Wed Jul 6 21:28:39 2005
New Revision: 2643
Added:
trunk/doc/test.pl
trunk/doc/test2.pl
trunk/src/NeoStats.pm
trunk/src/generate_header (contents, props changed)
Modified:
trunk/ChangeLog
trunk/src/Makefile.am
trunk/src/Makefile.in
trunk/src/main.c
trunk/src/modules.c
trunk/src/perl.c
Log:
basic perl module support... now to write all the hooks
Modified: trunk/ChangeLog
==============================================================================
--- trunk/ChangeLog (original)
+++ trunk/ChangeLog Wed Jul 6 21:28:39 2005
@@ -4,8 +4,9 @@
Fish (F), Mark (M), DeadNotBuried (D)
===============================================================================
* NeoStats * Version 3.0.a3-dev
+ - Basic Perl Support thanks to XChat. Now time to write all the Hooks (F)
- Change Source Layout, so we don't go and rebuild protocol and DB files
- all the time
+ all the time (F)
- Implement framework for Perl Support (F)
- Fix warnings that GCC 4.0 generates (F)
- LimitServ: set minimum limit settable by LimitServ to Users + 1 (D)
Added: trunk/doc/test.pl
==============================================================================
--- (empty file)
+++ trunk/doc/test.pl Wed Jul 6 21:28:39 2005
@@ -0,0 +1,4 @@
+sub pkg_load {
+ print "hello world\n";
+}
+pkg_load();
Added: trunk/doc/test2.pl
==============================================================================
--- (empty file)
+++ trunk/doc/test2.pl Wed Jul 6 21:28:39 2005
@@ -0,0 +1,6 @@
+sub pkg_load {
+ print "hello world\n";
+ print "this is my stupid message\n";
+ NeoStats::print("and this is a neostats message\n");
+}
+pkg_load();
Modified: trunk/src/Makefile.am
==============================================================================
--- trunk/src/Makefile.am (original)
+++ trunk/src/Makefile.am Wed Jul 6 21:28:39 2005
@@ -11,7 +11,7 @@
adnsreply.c adnssetup.c adnstransmit.c adnstypes.c \
oscalls.c ossocket.c osfile.c updates.c
if DO_PERL
-neostats_SOURCES += perl.c
+neostats_SOURCES += perl.c neostats.pm.h
else
neostats_SOURCES +=
endif
@@ -22,7 +22,10 @@
$(top_srcdir)/lib/event/libevent.a
neostats_LDFLAGS = --export-dynamic -rdynamic
-noinst_HEADERS = confuselexer.l
+noinst_HEADERS = confuselexer.l NeoStats.pm generate_header
+neostats.pm.h: generate_header
+ $(top_builddir)/src/generate_header
+
include $(top_srcdir)/autotools/rules.mk
Modified: trunk/src/Makefile.in
==============================================================================
--- trunk/src/Makefile.in (original)
+++ trunk/src/Makefile.in Wed Jul 6 21:28:39 2005
@@ -39,7 +39,7 @@
build_triplet = @build@
host_triplet = @host@
bin_PROGRAMS = neostats$(EXEEXT)
-@DO_PERL_TRUE@am__append_1 = perl.c
+@DO_PERL_TRUE@am__append_1 = perl.c neostats.pm.h
@DO_PERL_FALSE@am__append_2 =
DIST_COMMON = $(noinst_HEADERS) $(srcdir)/Makefile.am \
$(srcdir)/Makefile.in $(top_srcdir)/autotools/rules.mk
@@ -68,7 +68,7 @@
numerics.c settings.c botinfo.c adnscheck.c adnsevent.c \
adnsgeneral.c adnsparse.c adnsquery.c adnsreply.c adnssetup.c \
adnstransmit.c adnstypes.c oscalls.c ossocket.c osfile.c \
- updates.c perl.c
+ updates.c perl.c neostats.pm.h
@DO_PERL_TRUE@am__objects_1 = perl.$(OBJEXT)
am__objects_2 =
am_neostats_OBJECTS = auth.$(OBJEXT) bans.$(OBJEXT) bots.$(OBJEXT) \
@@ -252,7 +252,7 @@
$(top_srcdir)/lib/event/libevent.a
neostats_LDFLAGS = --export-dynamic -rdynamic
-noinst_HEADERS = confuselexer.l
+noinst_HEADERS = confuselexer.l NeoStats.pm generate_header
LINK = $(LIBTOOL) --tag=CXX --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \
$(AM_LDFLAGS) $(LDFLAGS) -o $@
@@ -550,6 +550,9 @@
uninstall-binPROGRAMS uninstall-info-am
+neostats.pm.h: generate_header
+ $(top_builddir)/src/generate_header
+
.c.o:
@USECCDV@ @echo "Building $@"
@am__fastdepCC_TRUE@ @if $(COMPILE) -MT $@ -MD -MP -MF "$(DEPDIR)/$*.Tpo" \
Added: trunk/src/NeoStats.pm
==============================================================================
--- (empty file)
+++ trunk/src/NeoStats.pm Wed Jul 6 21:28:39 2005
@@ -0,0 +1,568 @@
+BEGIN {
+ $INC{'NeoStats.pm'} = 'DUMMY';
+}
+
+use File::Spec();
+use File::Basename();
+use Symbol();
+
+{
+ package NeoStats;
+ use base qw(Exporter);
+# use strict;
+ use warnings;
+ our %EXPORT_TAGS = ( all => [
+ qw(register hook_server hook_command),
+ qw(hook_print hook_timer unhook print command),
+ qw(find_context get_context set_context),
+ qw(get_info get_prefs emit_print nickcmp),
+ qw(get_list context_info strip_code),
+ qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW),
+ qw(PRI_LOWEST EAT_NONE EAT_NeoStats EAT_PLUGIN),
+ qw(EAT_ALL KEEP REMOVE),
+ ],
+ constants => [
+ qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW),
+ qw(PRI_LOWEST EAT_NONE EAT_NeoStats),
+ qw(EAT_PLUGIN EAT_ALL FD_READ FD_WRITE),
+ qw(FD_EXCEPTION FD_NOTSOCKET KEEP REMOVE),
+ ],
+ hooks => [
+ qw(hook_server hook_command),
+ qw(hook_print hook_timer unhook),
+ ],
+ util => [
+ qw(register print command find_context),
+ qw(get_context set_context get_info get_prefs),
+ qw(emit_print nickcmp get_list context_info),
+ qw(strip_code),
+ ],
+ );
+
+ our @EXPORT = @{$EXPORT_TAGS{constants}};
+ our @EXPORT_OK = @{$EXPORT_TAGS{all}};
+
+ sub register {
+ my ($package) = caller;
+ ($package) = caller(1) if $package eq 'IRC';
+ my $pkg_info = NeoStats::Embed::pkg_info( $package );
+ my $filename = $pkg_info->{filename};
+
+ my ($name, $version, $description, $callback) = @_;
+ $description = "" unless defined $description;
+
+ $pkg_info->{shutdown} = $callback;
+ $pkg_info->{gui_entry} =
+ NeoStats::Internal::register( $name, $version, $description, $filename );
+
+ # keep with old behavior
+ return ();
+ }
+
+ sub hook_server {
+ return undef unless @_ >= 2;
+
+ my $message = shift;
+ my $callback = shift;
+ my $options = shift;
+ my ($package) = caller;
+ ($package) = caller(1) if $package eq 'IRC';
+ $callback = NeoStats::Embed::fix_callback( $package, $callback );
+ my ($priority, $data) = ( NeoStats::PRI_NORM, undef );
+
+ if ( ref( $options ) eq 'HASH' ) {
+ if ( exists( $options->{priority} ) && defined( $options->{priority} ) ) {
+ $priority = $options->{priority};
+ }
+ if ( exists( $options->{data} ) && defined( $options->{data} ) ) {
+ $data = $options->{data};
+ }
+ }
+
+ my $pkg_info = NeoStats::Embed::pkg_info( $package );
+ my $hook = NeoStats::Internal::hook_server( $message, $priority, $callback, $data);
+ push @{$pkg_info->{hooks}}, $hook if defined $hook;
+ return $hook;
+
+ }
+
+ sub hook_command {
+ return undef unless @_ >= 2;
+
+ my $command = shift;
+ my $callback = shift;
+ my $options = shift;
+ my ($package) = caller;
+ ($package) = caller(1) if $package eq 'IRC';
+ $callback = NeoStats::Embed::fix_callback( $package, $callback );
+ my ($priority, $help_text, $data) = ( NeoStats::PRI_NORM, '', undef );
+
+ if ( ref( $options ) eq 'HASH' ) {
+ if ( exists( $options->{priority} ) && defined( $options->{priority} ) ) {
+ $priority = $options->{priority};
+ }
+ if ( exists( $options->{help_text} ) && defined( $options->{help_text} ) ) {
+ $help_text = $options->{help_text};
+ }
+ if ( exists( $options->{data} ) && defined( $options->{data} ) ) {
+ $data = $options->{data};
+ }
+ }
+
+ my $pkg_info = NeoStats::Embed::pkg_info( $package );
+ my $hook = NeoStats::Internal::hook_command( $command, $priority, $callback,
+ $help_text, $data);
+ push @{$pkg_info->{hooks}}, $hook if defined $hook;
+ return $hook;
+
+ }
+
+ sub hook_print {
+ return undef unless @_ >= 2;
+
+ my $event = shift;
+ my $callback = shift;
+ my $options = shift;
+ my ($package) = caller;
+ ($package) = caller(1) if $package eq 'IRC';
+ $callback = NeoStats::Embed::fix_callback( $package, $callback );
+ my ($priority, $data) = ( NeoStats::PRI_NORM, undef );
+
+ if ( ref( $options ) eq 'HASH' ) {
+ if ( exists( $options->{priority} ) && defined( $options->{priority} ) ) {
+ $priority = $options->{priority};
+ }
+ if ( exists( $options->{data} ) && defined( $options->{data} ) ) {
+ $data = $options->{data};
+ }
+ }
+
+ my $pkg_info = NeoStats::Embed::pkg_info( $package );
+ my $hook = NeoStats::Internal::hook_print( $event, $priority, $callback, $data);
+ push @{$pkg_info->{hooks}}, $hook if defined $hook;
+ return $hook;
+
+ }
+
+
+ sub hook_timer {
+ return undef unless @_ >= 2;
+
+ my ($timeout, $callback, $data) = @_;
+ my ($package) = caller;
+ ($package) = caller(1) if $package eq 'IRC';
+ $callback = NeoStats::Embed::fix_callback( $package, $callback );
+
+ if ( ref( $data ) eq 'HASH' && exists( $data->{data} )
+ && defined( $data->{data} ) ) {
+ $data = $data->{data};
+ }
+
+ my $pkg_info = NeoStats::Embed::pkg_info( $package );
+ my $hook = NeoStats::Internal::hook_timer( $timeout, $callback, $data );
+ push @{$pkg_info->{hooks}}, $hook if defined $hook;
+ return $hook;
+
+ }
+
+ sub hook_fd {
+ return undef unless @_ >= 2;
+ my ($fd, $callback, $options) = @_;
+ return undef unless defined $fd && defined $callback;
+ my $fileno = fileno $fd;
+ return undef unless defined $fileno; # no underlying fd for this handle
+
+ my ($package) = caller;
+ ($package) = caller(1) if $package eq 'IRC';
+
+ $callback = NeoStats::Embed::fix_callback( $package, $callback );
+
+ my ($flags, $data) = (NeoStats::FD_READ, undef);
+
+ if( ref( $options ) eq 'HASH' ) {
+ if( exists( $options->{flags} ) && defined( $options->{flags} ) ) {
+ $flags = $options->{flags};
+ }
+ if( exists( $options->{data} ) && defined( $options->{data} ) ) {
+ $data = $options->{data};
+ }
+ }
+
+ my $cb = sub {
+ my $userdata = shift;
+ no strict 'refs';
+ return &{$userdata->{CB}}($userdata->{FD}, $userdata->{FLAGS},
+ $userdata->{DATA},
+ );
+ };
+
+ my $pkg_info = NeoStats::Embed::pkg_info( $package );
+ my $hook = NeoStats::Internal::hook_fd( $fileno, $cb, $flags,
+ { DATA => $data, FD => $fd, CB => $callback,
+ FLAGS => $flags,
+ } );
+ push @{$pkg_info->{hooks}}, $hook if defined $hook;
+ return $hook;
+ }
+
+ sub unhook {
+ my $hook = shift @_;
+ my $package = shift @_;
+ ($package) = caller unless $package;
+ my $pkg_info = NeoStats::Embed::pkg_info( $package );
+
+ if( $hook =~ /^\d+$/ && grep { $_ == $hook } @{$pkg_info->{hooks}} ) {
+ $pkg_info->{hooks} = [grep { $_ != $hook } @{$pkg_info->{hooks}}];
+ return NeoStats::Internal::unhook( $hook );
+ }
+
+ return ();
+ }
+
+ sub print {
+
+ my $text = shift @_;
+ return 1 unless $text;
+ if ( ref( $text ) eq 'ARRAY' ) {
+ if ( $, ) {
+ $text = join $, , @$text;
+ } else {
+ $text = join "", @$text;
+ }
+ }
+
+
+ if ( @_ >= 1 ) {
+ my $channel = shift @_;
+ my $server = shift @_;
+ my $old_ctx = NeoStats::get_context();
+ my $ctx = NeoStats::find_context( $channel, $server );
+
+ if ( $ctx ) {
+ NeoStats::set_context( $ctx );
+ NeoStats::Internal::debug( $text );
+ NeoStats::set_context( $old_ctx );
+ return 1;
+ } else {
+ return 0;
+ }
+ } else {
+ NeoStats::Internal::debug( $text );
+ return 1;
+ }
+
+ }
+
+ sub printf {
+ my $format = shift;
+ NeoStats::print( sprintf( $format, @_ ) );
+ }
+
+ sub command {
+
+ my $command = shift;
+ my @commands;
+ if ( ref( $command ) eq 'ARRAY' ) {
+ @commands = @$command;
+ } else {
+ @commands = ($command);
+ }
+ if ( @_ >= 1 ) {
+ my ($channel, $server) = @_;
+ my $old_ctx = NeoStats::get_context();
+ my $ctx = NeoStats::find_context( $channel, $server );
+
+ if ( $ctx ) {
+ NeoStats::set_context( $ctx );
+ NeoStats::Internal::command( $_ ) foreach @commands;
+ NeoStats::set_context( $old_ctx );
+ return 1;
+ } else {
+ return 0;
+ }
+ } else {
+ NeoStats::Internal::command( $_ ) foreach @commands;
+ return 1;
+ }
+
+ }
+
+ sub commandf {
+ my $format = shift;
+ NeoStats::command( sprintf( $format, @_ ) );
+ }
+
+ sub set_context {
+ my $context;
+
+ if ( @_ == 2 ) {
+ my ($channel, $server) = @_;
+ $context = NeoStats::find_context( $channel, $server );
+ } elsif ( @_ == 1 ) {
+ if ( $_[0] =~ /^\d+$/ ) {
+ $context = $_[0];
+ } else {
+ $context = NeoStats::find_context( $_[0] );
+ }
+ }
+
+ return $context ? NeoStats::Internal::set_context( $context ) : 0;
+ }
+
+ sub get_info {
+ my $id = shift;
+ my $info;
+
+ if ( defined( $id ) ) {
+ if ( grep { $id eq $_ } qw(state_cursor) ) {
+ $info = NeoStats::get_prefs( $id );
+ } else {
+ $info = NeoStats::Internal::get_info( $id );
+ }
+ }
+ return $info;
+ }
+
+ sub user_info {
+ my $nick = shift @_ || NeoStats::get_info( "nick" );
+ my $user;
+
+ for (NeoStats::get_list( "users" ) ) {
+ if ( NeoStats::nickcmp( $_->{nick}, $nick ) == 0 ) {
+ $user = $_;
+ last;
+ }
+ }
+ return $user;
+ }
+
+ sub context_info {
+ my $ctx = shift @_ || NeoStats::get_context;
+ my $old_ctx = NeoStats::get_context;
+ my @fields = (qw(away channel host inputbox libdirfs network nick server),
+ qw(topic version win_status NeoStatsdir NeoStatsdirfs state_cursor),
+ );
+
+ if (NeoStats::set_context( $ctx )) {
+ my %info;
+ for my $field ( @fields ) {
+ $info{$field} = NeoStats::get_info( $field );
+ }
+ NeoStats::set_context( $old_ctx );
+
+ return %info if wantarray;
+ return \%info;
+ } else {
+ return undef;
+ }
+ }
+
+ sub strip_code {
+ my $pattern =
+ qr/\cB| #Bold
+ \cC\d{0,2}(?:,\d{0,2})?| #Color
+ \cG| #Beep
+ \cO| #Reset
+ \cV| #Reverse
+ \c_ #Underline
+ /x;
+
+ if ( defined wantarray ) {
+ my $msg = shift;
+ $msg =~ s/$pattern//g;
+ return $msg;
+ } else {
+ $_[0] =~ s/$pattern//g;
+ }
+ }
+
+}
+
+$SIG{__WARN__} = sub {
+ my $message = shift @_;
+ my ($package) = caller;
+ my $pkg_info = NeoStats::Embed::pkg_info( $package );
+
+ if( $pkg_info ) {
+ $message =~ s/\(eval \d+\)/$pkg_info->{filename}/;
+ }
+ NeoStats::print( $message );
+};
+
+{
+ package NeoStats::Embed;
+ use strict;
+ use warnings;
+
+ # list of loaded scripts keyed by their package names
+ our %scripts;
+ 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 "NeoStats::Script::" . $string;
+ }
+
+ sub pkg_info {
+ my $package = shift @_;
+ return $scripts{$package};
+ }
+
+ 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];
+ }
+ return $callback;
+ }
+
+ sub load {
+NeoStats::print('haha');
+ 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} );
+ NeoStats::print( qq{'$filename' already loaded from '$pkg_info->{filename}'.\n} );
+ NeoStats::print( 'If this is a different script then it rename and try loading it again.' );
+ return 2;
+ }
+
+ 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::print( "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::register
+ $scripts{$package}{filename} = $file;
+
+ {
+# no strict; no warnings;
+ eval "package $package; $source;";
+ }
+
+ if ( $@ ) {
+ # something went wrong
+ NeoStats::print( "Error loading '$file':\n$@\n" );
+
+ # make sure the script list doesn't contain false information
+ unload( $scripts{$package}{filename} );
+ return 1;
+ }
+
+ } else {
+ NeoStats::print( "Error opening '$file': $!\n" );
+ return 2;
+ }
+
+ return 0;
+ }
+
+ sub unload {
+ my $file = shift @_;
+ my $package = file2pkg( $file );
+ my $pkg_info = pkg_info( $package );
+
+ if( $pkg_info ) {
+
+ if( exists $pkg_info->{hooks} ) {
+ for my $hook ( @{$pkg_info->{hooks}} ) {
+ NeoStats::unhook( $hook, $package );
+ }
+ }
+
+ # take care of the shutdown callback
+ if( exists $pkg_info->{shutdown} ) {
+ if( ref $pkg_info->{shutdown} eq 'CODE' ) {
+ $pkg_info->{shutdown}->();
+ } elsif( $pkg_info->{shutdown} ) {
+ eval {
+ no strict 'refs';
+ &{$pkg_info->{shutdown}};
+ };
+ }
+ }
+
+ if( exists $pkg_info->{gui_entry} ) {
+ plugingui_remove( $pkg_info->{gui_entry} );
+ }
+
+ Symbol::delete_package( $package );
+ delete $scripts{$package};
+ return NeoStats::EAT_ALL;
+ } else {
+ return NeoStats::EAT_NONE;
+ }
+ }
+
+ 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 NeoStats::EAT_ALL;
+ }
+
+ sub unload_all {
+ for my $package ( keys %scripts ) {
+ unload( $scripts{$package}->{filename} );
+ }
+ return NeoStats::EAT_ALL;
+ }
+
+# sub auto_load {
+
+# my $dir = NeoStats::get_info( "NeoStatsdirfs" ) || NeoStats::get_info( "NeoStatsdir" );
+# if( opendir my $dir_handle, $dir ) {
+# my @files = readdir $dir_handle;
+
+# for( @files ) {
+# my $fullpath = File::Spec->catfile( $dir, $_ );
+# load( $fullpath ) if $fullpath =~ m/\.pl$/i;
+# }
+# closedir $dir_handle;
+# }
+
+# }
+
+
+}
Added: trunk/src/generate_header
==============================================================================
--- (empty file)
+++ trunk/src/generate_header Wed Jul 6 21:28:39 2005
@@ -0,0 +1,33 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+my $output = "neostats.pm.h";
+
+open my $header, ">", $output or die "Couldn't open '$output': $!";
+
+print $header header( "NeoStats.pm" );
+
+close $header;
+
+sub header {
+ my $file = shift;
+ open my $input, "<", $file or die "Couldn't open '$file':$!";
+ my @file = <$input>;
+ close $file;
+ return toc(@file);
+}
+
+sub toc {
+ my @lines = @_;
+ for( @lines ) {
+ if( /^\s*$/s ) { $_ = qq{"\\n"\n}; next; }
+ if( /^\s*#/ ) { $_ = qq{"\\n"\n}; next; }
+ s/\\/\\\\/g; # double the number of \'s
+ s/"/\\"/g;
+ s/^\s*/"/;
+ s/\n/\\n"\n/;
+ }
+ return @lines;
+}
Modified: trunk/src/main.c
==============================================================================
--- trunk/src/main.c (original)
+++ trunk/src/main.c Wed Jul 6 21:28:39 2005
@@ -239,6 +239,10 @@
return NS_FAILURE;
if( InitDCC() != NS_SUCCESS )
return NS_FAILURE;
+#ifdef USE_PERL
+ if( Init_Perl() != NS_SUCCESS )
+ return NS_FAILURE;
+#endif
InitServices();
dlog( DEBUG1, "Core init successful" );
return NS_SUCCESS;
@@ -256,6 +260,7 @@
void FiniCore( void )
{
+ FiniPerl();
FiniDCC();
FiniCurl();
FiniUsers();
Modified: trunk/src/modules.c
==============================================================================
--- trunk/src/modules.c (original)
+++ trunk/src/modules.c Wed Jul 6 21:28:39 2005
@@ -404,6 +404,9 @@
irc_prefmsg (ns_botptr, cmdparams->source, __("Module: %d %s (%s)", cmdparams->source), mod_ptr->modnum, mod_ptr->info->name, mod_ptr->info->version);
irc_prefmsg (ns_botptr, cmdparams->source, " : %s", mod_ptr->info->description);
}
+#ifdef USE_PERL
+ ns_cmd_modperlist(cmdparams);
+#endif
irc_prefmsg (ns_botptr, cmdparams->source, __("End of Module List", cmdparams->source));
return 0;
}
Modified: trunk/src/perl.c
==============================================================================
--- trunk/src/perl.c (original)
+++ trunk/src/perl.c Wed Jul 6 21:28:39 2005
@@ -22,7 +22,811 @@
*/
/* @file NeoStats interface to Perl Interpreter
+ * based on perl plugin from Xchat client
*/
#include "neostats.h"
+#include "services.h"
+#undef _
+#include <sys/types.h>
+#include <dirent.h>
+static int perl_load_file (char *script_name);
+
+
+
+
+
+#ifdef WIN32
+/* TODO: Mark, I got no idea about this win32 stuff, I'll leave it here for you to look at */
+static DWORD
+child (char *str)
+{
+ MessageBoxA (0, str, "Perl DLL Error",
+ MB_OK | MB_ICONHAND | MB_SETFOREGROUND | MB_TASKMODAL);
+ return 0;
+}
+
+static void
+thread_mbox (char *str)
+{
+ DWORD tid;
+
+ CloseHandle (CreateThread (NULL, 0, (LPTHREAD_START_ROUTINE) child,
+ str, 0, &tid));
+}
+
+#endif
+
+/* leave this before XSUB.h, to avoid readdir() being redefined */
+static void
+perl_auto_load (void)
+{
+ DIR *dir;
+ struct dirent *ent;
+
+ dir = opendir ("modules");
+ if (dir) {
+ while ((ent = readdir (dir))) {
+ int len = strlen (ent->d_name);
+ if (len > 3 && strcasecmp (".pl", ent->d_name + len - 3) == 0) {
+ char *file = malloc (len + strlen ("modules") + 2);
+ sprintf (file, "modules/%s", ent->d_name);
+ dlog(DEBUG2, "Loading Perl Module %s", file);
+ perl_load_file (file);
+ free (file);
+ }
+ }
+ closedir (dir);
+ }
+}
+
+#include <EXTERN.h>
+#define WIN32IOP_H
+#include <perl.h>
+#include <XSUB.h>
+
+
+
+list_t *perlmods;
+
+typedef struct {
+ char filename[MAXPATH];
+ ModuleInfo *modinfo;
+ PerlInterpreter *my_perl;
+} PerlModInfo;
+
+extern void boot_DynaLoader (pTHX_ CV * cv);
+
+
+/*
+ this is used for autoload and shutdown callbacks
+*/
+static int
+execute_perl (PerlModInfo *pm, SV * function, char *args)
+{
+
+ int count, ret_value = 1;
+ SV *sv;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PERL_SET_CONTEXT(pm->my_perl);
+
+ PUSHMARK (SP);
+ XPUSHs (sv_2mortal (newSVpv (args, 0)));
+ PUTBACK;
+
+ count = call_sv (function, G_EVAL | G_SCALAR);
+ SPAGAIN;
+
+ sv = GvSV (gv_fetchpv ("@", TRUE, SVt_PV));
+ if (SvTRUE (sv)) {
+ nlog(LOG_WARNING, "Perl error: %s\n", SvPV(sv, count));
+ POPs; /* remove undef from the top of the stack */
+ } else if (count != 1) {
+ nlog(LOG_WARNING, "Perl error: expected 1 value from %s, "
+ "got: %d\n", (char *)function, count);
+ } else {
+ ret_value = POPi;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return ret_value;
+}
+
+#if 0
+
+static int
+generic_cb (int fd, int flags, void *userdata)
+{
+ HookData *data = (HookData *) userdata;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK (SP);
+ XPUSHs (data->userdata);
+ PUTBACK;
+
+ call_sv (data->callback, G_EVAL);
+ SPAGAIN;
+ if (SvTRUE (ERRSV)) {
+ xchat_printf (ph, "Error in generic callback %s", SvPV_nolen (ERRSV));
+ POPs; /* remove undef from the top of the stack */
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return XCHAT_EAT_ALL;
+}
+
+static int
+timer_cb (void *userdata)
+{
+ HookData *data = (HookData *) userdata;
+ int retVal = 0;
+ int count = 0;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK (SP);
+ XPUSHs (data->userdata);
+ PUTBACK;
+
+ count = call_sv (data->callback, G_EVAL);
+ SPAGAIN;
+
+ if (SvTRUE (ERRSV)) {
+ xchat_printf (ph, "Error in timer callback %s", SvPV_nolen (ERRSV));
+ POPs; /* remove undef from the top of the stack */
+ retVal = XCHAT_EAT_ALL;
+ } else {
+ if (count != 1) {
+ xchat_print (ph, "Timer handler should only return 1 value.");
+ retVal = XCHAT_EAT_NONE;
+ } else {
+ retVal = POPi;
+ if (retVal == 0) {
+ /* if 0 is return the timer is going to get unhooked */
+ PUSHMARK (SP);
+ XPUSHs (sv_2mortal (newSVuv (PTR2UV (data->hook))));
+ PUTBACK;
+
+ call_pv ("NeoStats::unhook", G_EVAL);
+ SPAGAIN;
+
+ SvREFCNT_dec (data->callback);
+
+ if (data->userdata) {
+ SvREFCNT_dec (data->userdata);
+ }
+ free (data);
+ }
+ }
+
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retVal;
+}
+
+static int
+server_cb (char *word[], char *word_eol[], void *userdata)
+{
+ HookData *data = (HookData *) userdata;
+ int retVal = 0;
+ int count = 0;
+
+ /* these must be initialized after SAVETMPS */
+ AV *wd = NULL;
+ AV *wd_eol = NULL;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+
+ wd = newAV ();
+ sv_2mortal ((SV *) wd);
+ wd_eol = newAV ();
+ sv_2mortal ((SV *) wd_eol);
+
+ for (count = 1;
+ (count < 32) && (word[count] != NULL) && (word[count][0] != 0);
+ count++) {
+ av_push (wd, newSVpv (word[count], 0));
+ }
+
+ for (count = 1; (count < 32) && (word_eol[count] != NULL)
+ && (word_eol[count][0] != 0); count++) {
+ av_push (wd_eol, newSVpv (word_eol[count], 0));
+ }
+
+ /* xchat_printf (ph, */
+ /* "Recieved %d words in server callback", av_len (wd)); */
+ PUSHMARK (SP);
+ XPUSHs (newRV_noinc ((SV *) wd));
+ XPUSHs (newRV_noinc ((SV *) wd_eol));
+ XPUSHs (data->userdata);
+ PUTBACK;
+
+ count = call_sv (data->callback, G_EVAL);
+ SPAGAIN;
+ if (SvTRUE (ERRSV)) {
+ xchat_printf (ph, "Error in server callback %s", SvPV_nolen (ERRSV));
+ POPs; /* remove undef from the top of the stack */
+ retVal = XCHAT_EAT_NONE;
+ } else {
+ if (count != 1) {
+ xchat_print (ph, "Server handler should only return 1 value.");
+ retVal = XCHAT_EAT_NONE;
+ } else {
+ retVal = POPi;
+ }
+
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retVal;
+}
+
+static int
+command_cb (char *word[], char *word_eol[], void *userdata)
+{
+ HookData *data = (HookData *) userdata;
+ int retVal = 0;
+ int count = 0;
+
+ /* these must be initialized after SAVETMPS */
+ AV *wd = NULL;
+ AV *wd_eol = NULL;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+
+ wd = newAV ();
+ sv_2mortal ((SV *) wd);
+ wd_eol = newAV ();
+ sv_2mortal ((SV *) wd_eol);
+
+ for (count = 1;
+ (count < 32) && (word[count] != NULL) && (word[count][0] != 0);
+ count++) {
+ av_push (wd, newSVpv (word[count], 0));
+ }
+
+ for (count = 1;
+ (count < 32) && (word_eol[count] != NULL) &&
+ (word_eol[count][0] != 0); count++) {
+ av_push (wd_eol, newSVpv (word_eol[count], 0));
+ }
+
+ /* xchat_printf (ph, "Recieved %d words in command callback", */
+ /* av_len (wd)); */
+ PUSHMARK (SP);
+ XPUSHs (newRV_noinc ((SV *) wd));
+ XPUSHs (newRV_noinc ((SV *) wd_eol));
+ XPUSHs (data->userdata);
+ PUTBACK;
+
+ count = call_sv (data->callback, G_EVAL);
+ SPAGAIN;
+ if (SvTRUE (ERRSV)) {
+ xchat_printf (ph, "Error in command callback %s", SvPV_nolen (ERRSV));
+ POPs; /* remove undef from the top of the stack */
+ retVal = XCHAT_EAT_NONE;
+ } else {
+ if (count != 1) {
+ xchat_print (ph, "Command handler should only return 1 value.");
+ retVal = XCHAT_EAT_NONE;
+ } else {
+ retVal = POPi;
+ }
+
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retVal;
+}
+
+/* custom IRC perl functions for scripting */
+
+/* NeoStats::Internal::register (scriptname, version, desc, shutdowncallback, filename)
+ *
+ */
+
+static
+XS (XS_Xchat_register)
+{
+ char *name, *version, *desc, *filename;
+ void *gui_entry;
+ dXSARGS;
+ if (items != 4) {
+ xchat_printf (ph,
+ "Usage: NeoStats::Internal::register(scriptname, version, desc, filename)");
+ } else {
+ name = SvPV_nolen (ST (0));
+ version = SvPV_nolen (ST (1));
+ desc = SvPV_nolen (ST (2));
+ filename = SvPV_nolen (ST (3));
+
+ gui_entry = xchat_plugingui_add (ph, filename, name,
+ desc, version, NULL);
+
+ XSRETURN_UV (PTR2UV (gui_entry));
+
+ }
+}
+
+#endif
+/* NeoStats::debug(output) */
+static
+XS (XS_NeoStats_debug)
+{
+
+ char *text = NULL;
+
+ dXSARGS;
+ if (items != 1) {
+ nlog(LOG_WARNING, "Usage: NeoStats::Internal::print(text)");
+ } else {
+ text = SvPV_nolen (ST (0));
+ nlog(LOG_WARNING, "%s", text);
+ }
+ XSRETURN_EMPTY;
+}
+#if 0
+static
+XS (XS_Xchat_emit_print)
+{
+ char *event_name;
+ int RETVAL;
+ int count;
+
+ dXSARGS;
+ if (items < 1) {
+ xchat_print (ph, "Usage: NeoStats::emit_print(event_name, ...)");
+ } else {
+ event_name = (char *) SvPV_nolen (ST (0));
+ RETVAL = 0;
+
+ /* we need to figure out the number of defined values passed in */
+ for (count = 0; count < items; count++) {
+ if (!SvOK (ST (count))) {
+ break;
+ }
+ }
+
+ switch (count) {
+ case 1:
+ RETVAL = xchat_emit_print (ph, event_name, NULL);
+ break;
+ case 2:
+ RETVAL = xchat_emit_print (ph, event_name,
+ SvPV_nolen (ST (1)), NULL);
+ break;
+ case 3:
+ RETVAL = xchat_emit_print (ph, event_name,
+ SvPV_nolen (ST (1)),
+ SvPV_nolen (ST (2)), NULL);
+ break;
+ case 4:
+ RETVAL = xchat_emit_print (ph, event_name,
+ SvPV_nolen (ST (1)),
+ SvPV_nolen (ST (2)),
+ SvPV_nolen (ST (3)), NULL);
+ break;
+ case 5:
+ RETVAL = xchat_emit_print (ph, event_name,
+ SvPV_nolen (ST (1)),
+ SvPV_nolen (ST (2)),
+ SvPV_nolen (ST (3)),
+ SvPV_nolen (ST (4)), NULL);
+ break;
+
+ }
+
+ XSRETURN_UV (RETVAL);
+ }
+}
+/* NeoStats::Internal::hook_event(name, callback, userdata) */
+static
+XS (XS_Xchat_hook_event)
+{
+
+ char *name;
+ int pri;
+ SV *callback;
+ SV *userdata;
+ xchat_hook *hook;
+ HookData *data;
+
+ dXSARGS;
+
+ if (items != 3) {
+ xchat_print (ph,
+ "Usage: NeoStats::Internal::hook_event(name, callback, userdata)");
+ } else {
+ name = SvPV_nolen (ST (0));
+ callback = ST (1);
+ userdata = ST (2);
+ 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);
+ hook = xchat_hook_server (ph, name, pri, server_cb, data);
+
+ XSRETURN_UV (PTR2UV (hook));
+ }
+}
+
+/* NeoStats::Internal::hook_command(name, callback, help_text, userdata) */
+static
+XS (XS_Xchat_hook_command)
+{
+ char *name;
+ int pri;
+ SV *callback;
+ char *help_text;
+ SV *userdata;
+ xchat_hook *hook;
+ HookData *data;
+
+ dXSARGS;
+
+ if (items != 4) {
+ xchat_print (ph,
+ "Usage: NeoStats::Internal::hook_command(name, callback, help_text, userdata)");
+ } else {
+ name = SvPV_nolen (ST (0));
+ callback = ST (1);
+ help_text = SvPV_nolen (ST (2));
+ userdata = ST (3);
+ 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);
+ hook = xchat_hook_command (ph, name, pri, command_cb, help_text, data);
+
+ XSRETURN_UV (PTR2UV (hook));
+ }
+
+}
+
+/* NeoStats::Internal::hook_timer(timeout, callback, userdata) */
+static
+XS (XS_Xchat_hook_timer)
+{
+ int timeout;
+ SV *callback;
+ SV *userdata;
+ xchat_hook *hook;
+ HookData *data;
+
+ dXSARGS;
+
+ if (items != 3) {
+ xchat_print (ph,
+ "Usage: NeoStats::Internal::hook_timer(timeout, callback, userdata)");
+ } else {
+ timeout = (int) SvIV (ST (0));
+ callback = ST (1);
+ data = NULL;
+ userdata = ST (2);
+
+ 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);
+ hook = xchat_hook_timer (ph, timeout, timer_cb, data);
+ data->hook = hook;
+
+ XSRETURN_UV (PTR2UV (hook));
+ }
+}
+
+static
+XS (XS_Xchat_unhook)
+{
+ xchat_hook *hook;
+ HookData *userdata;
+ int retCount = 0;
+ dXSARGS;
+ if (items != 1) {
+ xchat_print (ph, "Usage: NeoStats::unhook(hook)");
+ } else {
+ hook = INT2PTR (xchat_hook *, SvUV (ST (0)));
+ userdata = (HookData *) xchat_unhook (ph, hook);
+
+ if (userdata != NULL) {
+ if (userdata->callback) {
+ SvREFCNT_dec (userdata->callback);
+ }
+
+ if (userdata->userdata) {
+ XPUSHs (sv_mortalcopy (userdata->userdata));
+ SvREFCNT_dec (userdata->userdata);
+ retCount = 1;
+ }
+ }
+ free (userdata);
+ XSRETURN (retCount);
+ }
+ XSRETURN_EMPTY;
+}
+
+static
+XS (XS_Xchat_get_list)
+{
+ SV *name;
+ HV *hash;
+ xchat_list *list;
+ const char *const *fields;
+ const char *field;
+ int i = 0; /* field index */
+ int count = 0; /* return value for scalar context */
+ U32 context;
+ dXSARGS;
+
+ if (items != 1) {
+ xchat_print (ph, "Usage: NeoStats::get_list(name)");
+ } else {
+ SP -= items; /*remove the argument list from the stack */
+
+ name = ST (0);
+
+ list = xchat_list_get (ph, SvPV_nolen (name));
+
+ if (list == NULL) {
+ XSRETURN_EMPTY;
+ }
+
+ context = GIMME_V;
+
+ if (context == G_SCALAR) {
+ while (xchat_list_next (ph, list)) {
+ count++;
+ }
+ xchat_list_free (ph, list);
+ XSRETURN_IV ((IV) count);
+ }
+
+ fields = xchat_list_fields (ph, SvPV_nolen (name));
+ while (xchat_list_next (ph, list)) {
+ i = 0;
+ hash = newHV ();
+ sv_2mortal ((SV *) hash);
+ while (fields[i] != NULL) {
+ switch (fields[i][0]) {
+ case 's':
+ field = xchat_list_str (ph, list, fields[i] + 1);
+ if (field != NULL) {
+ hv_store (hash, fields[i] + 1, strlen (fields[i] + 1),
+ newSVpvn (field, strlen (field)), 0);
+ /* xchat_printf (ph, */
+ /* "string: %s - %d - %s", */
+ /* fields[i]+1, */
+ /* strlen(fields[i]+1), */
+ /* field, strlen(field) */
+ /* ); */
+ } else {
+ hv_store (hash, fields[i] + 1, strlen (fields[i] + 1),
+ &PL_sv_undef, 0);
+ /* xchat_printf (ph, */
+ /* "string: %s - %d - undef", */
+ /* fields[i]+1, */
+ /* strlen(fields[i]+1) */
+ /* ); */
+ }
+ break;
+ case 'p':
+ /* xchat_printf (ph, "pointer: %s", fields[i]+1); */
+ hv_store (hash, fields[i] + 1, strlen (fields[i] + 1),
+ newSVuv (PTR2UV (xchat_list_str (ph, list,
+ fields[i] + 1)
+ )), 0);
+ break;
+ case 'i':
+ hv_store (hash, fields[i] + 1, strlen (fields[i] + 1),
+ newSVuv (xchat_list_int (ph, list, fields[i] + 1)),
+ 0);
+ /* xchat_printf (ph, "int: %s - %d",fields[i]+1, */
+ /* xchat_list_int (ph, list, fields[i]+1) */
+ /* ); */
+ break;
+ case 't':
+ hv_store (hash, fields[i] + 1, strlen (fields[i] + 1),
+ newSVnv (xchat_list_time (ph, list, fields[i] + 1)),
+ 0);
+ break;
+ }
+ i++;
+ }
+
+ XPUSHs (newRV_noinc ((SV *) hash));
+
+ }
+ xchat_list_free (ph, list);
+
+ PUTBACK;
+ return;
+ }
+}
+
+#endif
+
+/* xs_init is the second argument perl_parse. As the name hints, it
+ initializes XS subroutines (see the perlembed manpage) */
+static void
+xs_init (pTHX)
+{
+#if 0
+ HV *stash;
+#endif
+ /* This one allows dynamic loading of perl modules in perl
+ scripts by the 'use perlmod;' construction */
+ newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
+ /* load up all the custom IRC perl functions */
+ newXS ("NeoStats::Internal::debug", XS_NeoStats_debug, __FILE__);
+#if 0
+ stash = get_hv ("NeoStats::", TRUE);
+ if (stash == NULL) {
+ exit (1);
+ }
+
+ newCONSTSUB (stash, "PRI_HIGHEST", newSViv (XCHAT_PRI_HIGHEST));
+ newCONSTSUB (stash, "PRI_HIGH", newSViv (XCHAT_PRI_HIGH));
+ newCONSTSUB (stash, "PRI_NORM", newSViv (XCHAT_PRI_NORM));
+ newCONSTSUB (stash, "PRI_LOW", newSViv (XCHAT_PRI_LOW));
+ newCONSTSUB (stash, "PRI_LOWEST", newSViv (XCHAT_PRI_LOWEST));
+
+ newCONSTSUB (stash, "EAT_NONE", newSViv (XCHAT_EAT_NONE));
+ newCONSTSUB (stash, "EAT_XCHAT", newSViv (XCHAT_EAT_XCHAT));
+ newCONSTSUB (stash, "EAT_PLUGIN", newSViv (XCHAT_EAT_PLUGIN));
+ newCONSTSUB (stash, "EAT_ALL", newSViv (XCHAT_EAT_ALL));
+ newCONSTSUB (stash, "FD_READ", newSViv (XCHAT_FD_READ));
+ newCONSTSUB (stash, "FD_WRITE", newSViv (XCHAT_FD_WRITE));
+ newCONSTSUB (stash, "FD_EXCEPTION", newSViv (XCHAT_FD_EXCEPTION));
+ newCONSTSUB (stash, "FD_NOTSOCKET", newSViv (XCHAT_FD_NOTSOCKET));
+ newCONSTSUB (stash, "KEEP", newSViv (1));
+ newCONSTSUB (stash, "REMOVE", newSViv (0));
+#endif
+}
+
+int
+Init_Perl (void)
+{
+ /* create the perl modules list */
+ perlmods = list_create(-1);
+
+ /* now load the modules */
+ perl_auto_load();
+ return NS_SUCCESS;
+}
+
+
+static int
+perl_load_file (char *filename)
+{
+ char *perl_args[] = { "", "-e", "0", "-w" };
+ const char perl_definitions[] = {
+#include "neostats.pm.h"
+ };
+ PerlModInfo *pm;
+ lnode_t *node;
+
+
+
+#ifdef WIN32
+ static HINSTANCE lib = NULL;
+
+ if (!lib) {
+ lib = LoadLibrary (PERL_DLL);
+ if (!lib) {
+ thread_mbox ("Cannot open " PERL_DLL "\n\n"
+ "You must have ActivePerl installed in order to\n"
+ "run perl scripts.\n\n"
+ "http://www.activestate.com/ActivePerl/\n\n"
+ "Make sure perl's bin directory is in your PATH.");
+ return FALSE;
+ }
+ FreeLibrary (lib);
+ }
+#endif
+
+ pm = os_malloc(sizeof(PerlModInfo));
+ pm->modinfo = os_malloc(sizeof(ModuleInfo));
+ strlcpy(pm->filename, filename, MAXPATH);
+ pm->my_perl = perl_alloc ();
+ PL_perl_destruct_level = 1;
+ perl_construct (pm->my_perl);
+
+ perl_parse (pm->my_perl, xs_init, 4, perl_args, NULL);
+ /*
+ Now initialising the perl interpreter by loading the
+ perl_definition array.
+ */
+ eval_pv (perl_definitions, TRUE);
+
+ if (!execute_perl (pm, sv_2mortal (newSVpv ("NeoStats::Embed::load", 0)),
+ filename)) {
+ /* it loaded ok */
+ nlog(LOG_NORMAL, "Loaded Perl Module %s", filename);
+ } else {
+ nlog(LOG_WARNING, "Errors in Perl Module %s", filename);
+ perl_destruct (pm->my_perl);
+ perl_free (pm->my_perl);
+ free(pm->modinfo);
+ free(pm);
+ }
+
+ node = lnode_create(pm);
+ list_append(perlmods, node);
+ return NS_SUCCESS;
+}
+
+void
+FiniPerl (void)
+{
+ lnode_t *node;
+ PerlModInfo *pm;
+ node = list_first(perlmods);
+ while (node != NULL) {
+ pm = lnode_get(node);
+ execute_perl (pm, sv_2mortal (newSVpv ("NeoStats::Embed::unload", 0)), pm->filename);
+ perl_destruct (pm->my_perl);
+ perl_free (pm->my_perl);
+ free(pm->modinfo);
+ free(pm);
+ node = list_next(perlmods, node);
+ }
+}
+
+void ns_cmd_modperlist(CmdParams *cmd) {
+ lnode_t *node;
+ PerlModInfo *pm;
+ node = list_first(perlmods);
+ while (node != NULL) {
+ pm = lnode_get(node);
+ irc_prefmsg(ns_botptr, cmd->source,__("Perl Module: %s (%s)", cmd->source), pm->filename, pm->modinfo->version);
+ irc_prefmsg(ns_botptr, cmd->source," : %s", pm->modinfo->description);
+ node = list_next(perlmods, node);
+ }
+}