Rework modperl to better integrate with perl.

Now it supports global and network modules. Fixes github issue #82
2026-03-28 17:42:41 +01:00 · 2011-12-29 11:35:25 +07:00
parent 9e047a3beb
commit 8bb7ea5370
5 changed files with 133 additions and 171 deletions
--- a/modules/modperl.cpp
+++ b/modules/modperl.cpp
@@ -76,14 +76,13 @@ public:

 	virtual EModRet OnModuleLoading(const CString& sModName, const CString& sArgs,
 			CModInfo::EModuleType eType, bool& bSuccess, CString& sRetMsg) {
-		if (!GetUser() || eType != CModInfo::UserModule) {
-			return CONTINUE;
-		}
 		EModRet result = HALT;
 		PSTART;
 		PUSH_STR(sModName);
 		PUSH_STR(sArgs);
+		mXPUSHi(eType);
 		PUSH_PTR(CUser*, GetUser());
+		PUSH_PTR(CIRCNetwork*, GetNetwork());
 		PCALL("ZNC::Core::LoadModule");

 		if (SvTRUE(ERRSV)) {
@@ -115,7 +114,7 @@ public:
 		if (pMod) {
 			CString sModName = pMod->GetModName();
 			PSTART;
-			PUSH_PTR(CPerlModule*, pMod);
+			XPUSHs(pMod->GetPerlObj());
 			PCALL("ZNC::Core::UnloadModule");
 			if (SvTRUE(ERRSV)) {
 				bSuccess = false;
@@ -135,6 +134,7 @@ public:
 			bool& bSuccess, CString& sRetMsg) {
 		PSTART;
 		PUSH_STR(sModule);
+		PUSH_PTR(CModInfo*, &ModInfo);
 		PCALL("ZNC::Core::GetModInfo");
 		EModRet result = CONTINUE;
 		if (SvTRUE(ERRSV)) {
@@ -147,13 +147,7 @@ public:
 					break;
 				case Perl_Loaded:
 					result = HALT;
-					if (4 == ret) {
-						ModInfo.SetDefaultType(CModInfo::UserModule);
-						ModInfo.AddType(CModInfo::UserModule);
-						ModInfo.SetDescription(PString(ST(2)));
-						ModInfo.SetName(sModule);
-						ModInfo.SetPath(PString(ST(1)));
-						ModInfo.SetWikiPage(PString(ST(3)));
+					if (1 == ret) {
 						bSuccess = true;
 					} else {
 						bSuccess = false;
@@ -175,14 +169,10 @@ public:
 			sRetMsg = "Something weird happened";
 		}
 		PEND;
-		DEBUG(__PRETTY_FUNCTION__ << " " << sRetMsg);
 		return result;
 	}

 	virtual void OnGetAvailableMods(set<CModInfo>& ssMods, CModInfo::EModuleType eType) {
-		if (eType != CModInfo::UserModule) {
-			return;
-		}

 		unsigned int a = 0;
 		CDir Dir;
@@ -202,13 +192,9 @@ public:
 				PSTART;
 				PUSH_STR(sPath);
 				PUSH_STR(sName);
+				PUSH_PTR(CModInfo*, &ModInfo);
 				PCALL("ZNC::Core::ModInfoByPath");
 				if (!SvTRUE(ERRSV) && ret == 2) {
-					ModInfo.AddType(CModInfo::UserModule);
-					ModInfo.SetDescription(PString(ST(0)));
-					ModInfo.SetName(sName);
-					ModInfo.SetPath(sPath);
-					ModInfo.SetWikiPage(PString(ST(1)));
 					ssMods.insert(ModInfo);
 				}
 				PEND;
@@ -243,8 +229,7 @@ void CPerlTimer::RunJob() {
 	CPerlModule* pMod = AsPerlModule(GetModule());
 	if (pMod) {
 		PSTART;
-		PUSH_STR(pMod->GetPerlID());
-		PUSH_STR(GetPerlID());
+		XPUSHs(GetPerlObj());
 		PCALL("ZNC::Core::CallTimer");
 		PEND;
 	}
@@ -254,14 +239,13 @@ CPerlTimer::~CPerlTimer() {
 	CPerlModule* pMod = AsPerlModule(GetModule());
 	if (pMod) {
 		PSTART;
-		PUSH_STR(pMod->GetPerlID());
-		PUSH_STR(GetPerlID());
+		XPUSHs(sv_2mortal(m_perlObj));
 		PCALL("ZNC::Core::RemoveTimer");
 		PEND;
 	}
 }

-#define SOCKSTART PSTART; PUSH_STR(pMod->GetPerlID()); PUSH_STR(GetPerlID())
+#define SOCKSTART PSTART; XPUSHs(GetPerlObj())
 #define SOCKCBCHECK(OnSuccess) PCALL("ZNC::Core::CallSocket"); if (SvTRUE(ERRSV)) { Close(); DEBUG("Perl socket hook died with: " + PString(ERRSV)); } else { OnSuccess; } PEND
 #define CBSOCK(Func) void CPerlSocket::Func() {\
 	CPerlModule* pMod = AsPerlModule(GetModule());\
@@ -313,7 +297,8 @@ Csock* CPerlSocket::GetSockObj(const CString& sHost, unsigned short uPort) {
 CPerlSocket::~CPerlSocket() {
 	CPerlModule* pMod = AsPerlModule(GetModule());
 	if (pMod) {
-		SOCKSTART;
+		PSTART;
+		XPUSHs(sv_2mortal(m_perlObj));
 		PCALL("ZNC::Core::RemoveSocket");
 		PEND;
 	}
--- a/modules/modperl/codegen.pl
+++ b/modules/modperl/codegen.pl
@@ -64,7 +64,7 @@ namespace {
 #define PUSH_STR(s) XPUSHs(PString(s).GetSV())
 #define PUSH_PTR(type, p) XPUSHs(SWIG_NewInstanceObj(const_cast<type>(p), SWIG_TypeQuery(#type), SWIG_SHADOW))
 */
-#define PSTART_IDF(Func) PSTART; PUSH_STR(GetPerlID()); PUSH_STR(#Func)
+#define PSTART_IDF(Func) PSTART; XPUSHs(GetPerlObj()); PUSH_STR(#Func)
 #define PCALLMOD(Error, Success) PCALL("ZNC::Core::CallModFunc"); if (SvTRUE(ERRSV)) { DEBUG("Perl hook died with: " + PString(ERRSV)); Error; } else { Success; } PEND

 EOF
--- a/modules/modperl/modperl.i
+++ b/modules/modperl/modperl.i
@@ -24,6 +24,7 @@
 #include "../include/znc/Nick.h"
 #include "../include/znc/Chan.h"
 #include "../include/znc/User.h"
+#include "../include/znc/IRCNetwork.h"
 #include "../include/znc/Client.h"
 #include "../include/znc/IRCSock.h"
 #include "../include/znc/Listener.h"
@@ -87,6 +88,7 @@ namespace std {
 %include "../include/znc/Nick.h"
 %include "../include/znc/Chan.h"
 %include "../include/znc/User.h"
+%include "../include/znc/IRCNetwork.h"
 %include "../include/znc/Client.h"
 %include "../include/znc/IRCSock.h"
 %include "../include/znc/Listener.h"
--- a/modules/modperl/module.h
+++ b/modules/modperl/module.h
@@ -8,21 +8,27 @@

 #pragma once

+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+
 #include <znc/Modules.h>

 #if HAVE_VISIBILITY
 #pragma GCC visibility push(default)
 #endif
 class CPerlModule : public CModule {
-	CString m_sPerlID;
+	SV* m_perlObj;
 	VWebSubPages* _GetSubPages();
 public:
 	CPerlModule(CUser* pUser, CIRCNetwork* pNetwork, const CString& sModName, const CString& sDataPath,
-			const CString& sPerlID)
+			SV* perlObj)
 			: CModule(NULL, pUser, pNetwork, sModName, sDataPath) {
-		m_sPerlID = sPerlID;
+		m_perlObj = newSVsv(perlObj);
+	}
+	SV* GetPerlObj() {
+		return sv_2mortal(newSVsv(m_perlObj));
 	}
-	CString GetPerlID() { return m_sPerlID; }

 	virtual bool OnBoot();
 	virtual bool WebRequiresLogin();
@@ -99,27 +105,31 @@ enum ELoadPerlMod {
 };

 class CPerlTimer : public CTimer {
-	CString m_sPerlID;
+	SV* m_perlObj;
 public:
-	CPerlTimer(CPerlModule* pModule, unsigned int uInterval, unsigned int uCycles, const CString& sLabel, const CString& sDescription, const CString& sPerlID)
-					: CTimer (pModule, uInterval, uCycles, sLabel, sDescription), m_sPerlID(sPerlID) {
+	CPerlTimer(CPerlModule* pModule, unsigned int uInterval, unsigned int uCycles, const CString& sLabel, const CString& sDescription, SV* perlObj)
+					: CTimer (pModule, uInterval, uCycles, sLabel, sDescription), m_perlObj(newSVsv(perlObj)) {
 		pModule->AddTimer(this);
 	}
 	virtual void RunJob();
-	CString GetPerlID() { return m_sPerlID; }
+	SV* GetPerlObj() {
+		return sv_2mortal(newSVsv(m_perlObj));
+	}
 	~CPerlTimer();
 };

 inline CPerlTimer* CreatePerlTimer(CPerlModule* pModule, unsigned int uInterval, unsigned int uCycles,
-		const CString& sLabel, const CString& sDescription, const CString& sPerlID) {
-	return new CPerlTimer(pModule, uInterval, uCycles, sLabel, sDescription, sPerlID);
+		const CString& sLabel, const CString& sDescription, SV* perlObj) {
+	return new CPerlTimer(pModule, uInterval, uCycles, sLabel, sDescription, perlObj);
 }

 class CPerlSocket : public CSocket {
-	CString m_sPerlID;
+	SV* m_perlObj;
 public:
-	CPerlSocket(CPerlModule* pModule, const CString& sPerlID) : CSocket(pModule), m_sPerlID(sPerlID) {}
-	CString GetPerlID() { return m_sPerlID; }
+	CPerlSocket(CPerlModule* pModule, SV* perlObj) : CSocket(pModule), m_perlObj(newSVsv(perlObj)) {}
+	SV* GetPerlObj() {
+		return sv_2mortal(newSVsv(m_perlObj));
+	}
 	~CPerlSocket();
 	virtual void Connected();
 	virtual void Disconnected();
@@ -130,8 +140,8 @@ public:
 	virtual Csock* GetSockObj(const CString& sHost, unsigned short uPort);
 };

-inline CPerlSocket* CreatePerlSocket(CPerlModule* pModule, const CString& sPerlID) {
-	return new CPerlSocket(pModule, sPerlID);
+inline CPerlSocket* CreatePerlSocket(CPerlModule* pModule, SV* perlObj) {
+	return new CPerlSocket(pModule, perlObj);
 }

 inline bool HaveIPv6() {
--- a/modules/modperl/startup.pl
+++ b/modules/modperl/startup.pl
@@ -15,69 +15,40 @@ use feature 'switch', 'say';

 package ZNC::Core;

-my $uuidtype;
-my $uuidgen;
-our %pmods;
 my %modrefcount;
+my @allmods;

-sub Init {
-	if (eval { require Data::UUID }) {
-		$uuidtype = 'Data::UUID';
-		$uuidgen = new Data::UUID;
-	} elsif (eval { require UUID }) {
-		$uuidtype = 'UUID';
-	} else {
-		$uuidtype = 'int';
-		$uuidgen = 0;
-	}
-}
-
-sub CreateUUID {
-	my $res;
-	given ($uuidtype) {
-		when ('Data::UUID') {
-			$res = $uuidgen->create_str;
+sub UnloadModule {
+	my ($pmod) = @_;
+	$pmod->OnShutdown;
+	@allmods = grep {$pmod != $_} @allmods;
+	my $cmod = $pmod->{_cmod};
+	my $modpath = $cmod->GetModPath;
+	my $modname = $cmod->GetModName;
+	given ($cmod->GetType()) {
+		when ($ZNC::CModInfo::NetworkModule) {
+			$cmod->GetNetwork->GetModules->removeModule($cmod);
 		}
-		when ('UUID') {
-			my ($uuid, $str);
-			UUID::generate($uuid);
-			UUID::unparse($uuid, $res);
+		when ($ZNC::CModInfo::UserModule) {
+			$cmod->GetUser->GetModules->removeModule($cmod);
 		}
-		when ('int') {
-			$uuidgen++;
-			$res = "$uuidgen";
+		when ($ZNC::CModInfo::GlobalModule) {
+			ZNC::CZNC::Get()->GetModules->removeModule($cmod);
 		}
 	}
-	say "Created new UUID for modperl with '$uuidtype': $res";
-	return $res;
-}
-
-sub unloadByIDUser {
-	my ($id, $user) = @_;
-	my $modpath = $pmods{$id}{_cmod}->GetModPath;
-	my $modname = $pmods{$id}{_cmod}->GetModName;
-	$pmods{$id}->OnShutdown;
-	$user->GetModules->removeModule($pmods{$id}{_cmod});
-	delete $pmods{$id}{_cmod};# Just for the case
-	delete $pmods{$id}{_nv};
-	delete $pmods{$id}{_ptimers};
-	delete $pmods{$id}{_sockets};
-	delete $pmods{$id};
+	delete $pmod->{_cmod};
+	delete $pmod->{_nv};
 	unless (--$modrefcount{$modname}) {
 		say "Unloading $modpath from perl";
 		ZNC::_CleanupStash($modname);
 		delete $INC{$modpath};
 	}
-}
-
-sub UnloadModule {
-	my ($cmod) = @_;
-	unloadByIDUser($cmod->GetPerlID, $cmod->GetUser);
+	# here $cmod is deleted by perl (using DESTROY)
 }

 sub UnloadAll {
-	while (my ($id, $pmod) = each %pmods) {
-		unloadByIDUser($id, $pmod->{_cmod}->GetUser);
+	while (@allmods) {
+		UnloadModule($allmods[0]);
 	}
 }

@@ -89,39 +60,55 @@ sub IsModule {
 }

 sub LoadModule {
-	my ($modname, $args, $user) = @_;
+	my ($modname, $args, $type, $user, $network) = @_;
 	$modname =~ /^\w+$/ or return ($ZNC::Perl_LoadError, "Module names can only contain letters, numbers and underscores, [$modname] is invalid.");
-	return ($ZNC::Perl_LoadError, "Module [$modname] already loaded.") if defined $user->GetModules->FindModule($modname);
+	my $container;
+	given ($type) {
+		when ($ZNC::CModInfo::NetworkModule) {
+			$container = $network;
+		}
+		when ($ZNC::CModInfo::UserModule) {
+			$container = $user;
+		}
+		when ($ZNC::CModInfo::GlobalModule) {
+			$container = ZNC::CZNC::Get();
+		}
+	}
+	return ($ZNC::Perl_LoadError, "Uhm? No container for the module? Wtf?") unless $container;
+	$container = $container->GetModules;
+	return ($ZNC::Perl_LoadError, "Module [$modname] already loaded.") if defined $container->FindModule($modname);
 	my $modpath = ZNC::String->new;
 	my $datapath = ZNC::String->new;
 	ZNC::CModules::FindModPath("$modname.pm", $modpath, $datapath) or return ($ZNC::Perl_NotFound);
 	$modpath = $modpath->GetPerlStr;
 	return ($ZNC::Perl_LoadError, "Incorrect perl module [$modpath]") unless IsModule $modpath, $modname;
-	eval {
+	my $pmod;
+	my @types = eval {
 		require $modpath;
+		$pmod = bless {}, $modname;
+		$pmod->module_types();
 	};
 	if ($@) {
-		# modrefcount was 0 before this, otherwise it couldn't die.
+		# modrefcount was 0 before this, otherwise it couldn't die in the previous time.
 		# so can safely remove module from %INC
 		delete $INC{$modpath};
 		die $@;
 	}
+	return ($ZNC::Perl_LoadError, "Module [$modname] doesn't support the specified type.") unless $type ~~ @types;
 	$modrefcount{$modname}++;
-	my $id = CreateUUID;
 	$datapath = $datapath->GetPerlStr;
 	$datapath =~ s/\.pm$//;
-	my $cmod = ZNC::CPerlModule->new($user, $modname, $datapath, $id);
+	my $cmod = ZNC::CPerlModule->new($user, $network, $modname, $datapath, $pmod);
 	my %nv;
 	tie %nv, 'ZNC::ModuleNV', $cmod;
-	my $pmod = bless {
-		_cmod=>$cmod,
-		_nv=>\%nv
-	}, $modname;
+	$pmod->{_cmod} = $cmod;
+	$pmod->{_nv} = \%nv;
 	$cmod->SetDescription($pmod->description);
 	$cmod->SetArgs($args);
 	$cmod->SetModPath($modpath);
-	$pmods{$id} = $pmod;
-	$user->GetModules->push_back($cmod);
+	$cmod->SetType($type);
+	push @allmods, $pmod;
+	$container->push_back($cmod);
 	my $x = '';
 	my $loaded = 0;
 	eval {
@@ -132,7 +119,7 @@ sub LoadModule {
 		$x .= $@;
 	}
 	if (!$loaded) {
-		unloadByIDUser($id, $user);
+		UnloadModule $pmod;
 		if ($x) {
 			return ($ZNC::Perl_LoadError, "Module [$modname] aborted: $x");
 		}
@@ -145,7 +132,7 @@ sub LoadModule {
 }

 sub GetModInfo {
-	my ($modname) = @_;
+	my ($modname, $modinfo) = @_;
 	$modname =~ /^\w+$/ or return ($ZNC::Perl_LoadError, "Module names can only contain letters, numbers and underscores, [$modname] is invalid.");
 	my $modpath = ZNC::String->new;
 	my $datapath = ZNC::String->new;
@@ -154,23 +141,36 @@ sub GetModInfo {
 	return ($ZNC::Perl_LoadError, "Incorrect perl module.") unless IsModule $modpath, $modname;
 	require $modpath;
 	my $pmod = bless {}, $modname;
-	return ($ZNC::Perl_Loaded, $modpath, $pmod->description, $pmod->wiki_page)
+	my @types = $pmod->module_types;
+	$modinfo->SetDefaultType($types[0]);
+	$modinfo->SetDescription($pmod->description);
+	$modinfo->SetWikiPage($pmod->wiki_page);
+	$modinfo->SetName($modname);
+	$modinfo->SetPath($modpath);
+	$modinfo->AddType($_) for @types;
+	return ($ZNC::Perl_Loaded)
 }

 sub ModInfoByPath {
-	my ($modpath, $modname) = @_;
+	my ($modpath, $modname, $modinfo) = @_;
 	die "Incorrect perl module." unless IsModule $modpath, $modname;
 	require $modpath;
 	my $pmod = bless {}, $modname;
-	return ($pmod->description, $pmod->wiki_page)
+	my @types = $pmod->module_types;
+	$modinfo->SetDefaultType($types[0]);
+	$modinfo->SetDescription($pmod->description);
+	$modinfo->SetWikiPage($pmod->wiki_page);
+	$modinfo->SetName($modname);
+	$modinfo->SetPath($modpath);
+	$modinfo->AddType($_) for @types;
 }

 sub CallModFunc {
-	my $id = shift;
+	my $pmod = shift;
 	my $func = shift;
 	my $default = shift;
 	my @arg = @_;
-	my $res = $pmods{$id}->$func(@arg);
+	my $res = $pmod->$func(@arg);
 #	print "Returned from $func(@_): $res, (@arg)\n";
 	unless (defined $res) {
 		$res = $default if defined $default;
@@ -179,26 +179,25 @@ sub CallModFunc {
 }

 sub CallTimer {
-	my $modid = shift;
-	my $timerid = shift;
-	$pmods{$modid}->_CallTimer($timerid)
+	my $timer = shift;
+	$timer->RunJob;
 }

 sub CallSocket {
-	my $modid = shift;
-	$pmods{$modid}->_CallSocket(@_)
+	my $socket = shift;
+	my $func = shift;
+	say "Calling socket $func";
+	$socket->$func(@_)
 }

 sub RemoveTimer {
-	my $modid = shift;
-	my $timerid = shift;
-	$pmods{$modid}->_RemoveTimer($timerid)
+	my $timer = shift;
+	$timer->OnShutdown;
 }

 sub RemoveSocket {
-	my $modid = shift;
-	my $sockid = shift;
-	$pmods{$modid}->_RemoveSocket($sockid)
+	my $socket = shift;
+	$socket->OnShutdown;
 }

 package ZNC::ModuleNV;
@@ -283,6 +282,10 @@ sub wiki_page {
 	''
 }

+sub module_types {
+	$ZNC::CModInfo::NetworkModule
+}
+
 # Default implementations for module hooks. They can be overriden in derived modules.
 sub OnLoad {1}
 sub OnBoot {}
@@ -386,20 +389,16 @@ sub NV {

 sub CreateTimer {
 	my $self = shift;
-	my $id = ZNC::Core::CreateUUID;
 	my %a = @_;
+	my $ptimer = {};
 	my $ctimer = ZNC::CreatePerlTimer(
 			$self->{_cmod},
 			$a{interval}//10,
 			$a{cycles}//1,
-			"perl-timer-$id",
+			"perl-timer",
 			$a{description}//'Just Another Perl Timer',
-			$id);
-	my $ptimer = {
-		_ctimer=>$ctimer,
-		_modid=>$self->GetPerlID
-	};
-	$self->{_ptimers}{$id} = $ptimer;
+			$ptimer);
+	$ptimer->{_ctimer} = $ctimer;
 	if (ref($a{task}) eq 'CODE') {
 		bless $ptimer, 'ZNC::Timer';
 		$ptimer->{job} = $a{task};
@@ -410,55 +409,21 @@ sub CreateTimer {
 	$ptimer;
 }

-sub _CallTimer {
-	my $self = shift;
-	my $id = shift;
-	my $t = $self->{_ptimers}{$id};
-	$t->RunJob;
-}
-
-sub _RemoveTimer {
-	my $self = shift;
-	my $id = shift;
-	say "Removing perl timer $id";
-	$self->{_ptimers}{$id}->OnShutdown;
-	delete $self->{_ptimers}{$id}
-}
-
 sub CreateSocket {
 	my $self = shift;
 	my $class = shift;
-	my $id = ZNC::Core::CreateUUID;
-	my $csock = ZNC::CreatePerlSocket($self->{_cmod}, $id);
-	my $psock = bless {
-		_csock=>$csock,
-		_modid=>$self->GetPerlID
-	}, $class;
-	$self->{_sockets}{$id} = $psock;
+	my $psock = bless {}, $class;
+	my $csock = ZNC::CreatePerlSocket($self->{_cmod}, $psock);
+	$psock->{_csock} = $csock;
 	$psock->Init(@_);
 	$psock;
 }

-sub _CallSocket {
-	my $self = shift;
-	my $id = shift;
-	my $func = shift;
-	$self->{_sockets}{$id}->$func(@_)
-}
-
-sub _RemoveSocket {
-	my $self = shift;
-	my $id = shift;
-	say "Removing perl socket $id";
-	$self->{_sockets}{$id}->OnShutdown;
-	delete $self->{_sockets}{$id}
-}
-
 package ZNC::Timer;

 sub GetModule {
 	my $self = shift;
-	$ZNC::Core::pmods{$self->{_modid}};
+	ZNC::AsPerlModule($self->{_ctimer}->GetModule)->GetPerlObj()
 }

 sub RunJob {
@@ -492,7 +457,7 @@ package ZNC::Socket;

 sub GetModule {
 	my $self = shift;
-	$ZNC::Core::pmods{$self->{_modid}};
+	ZNC::AsPerlModule($self->{_csock}->GetModule)->GetPerlObj()
 }

 sub Init {}
@@ -537,7 +502,7 @@ sub Connect {
 	$self->GetModule->GetManager->Connect(
 			$host,
 			$port,
-			"perl-socket-".$self->GetPerlID,
+			"perl-socket",
 			$arg{timeout}//60,
 			$arg{ssl}//0,
 			$arg{bindhost}//'',
@@ -560,7 +525,7 @@ sub Listen {
 	if (defined $arg{port}) {
 		return $arg{port} if $self->GetModule->GetManager->ListenHost(
 				$arg{port},
-				"perl-socket-".$self->GetPerlID,
+				"perl-socket",
 				$arg{bindhost}//'',
 				$arg{ssl}//0,
 				$arg{maxconns}//ZNC::_GetSOMAXCONN,
@@ -571,7 +536,7 @@ sub Listen {
 		return 0;
 	}
 	$self->GetModule->GetManager->ListenRand(
-			"perl-socket-".$self->GetPerlID,
+			"perl-socket",
 			$arg{bindhost}//'',
 			$arg{ssl}//0,
 			$arg{maxconns}//ZNC::_GetSOMAXCONN,