znc/modules/modperl/startup.pl

#
# Copyright (C) 2004-2010  See the AUTHORS file for details.
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License version 2 as published
# by the Free Software Foundation.
#

use strict;
use warnings;
use ZNC;
use Data::UUID;
use IO::File;
use feature 'switch';

package ZNC::Core;

my $uuidgen;
our %pmods;

sub Init {
	$uuidgen = new Data::UUID;
}

sub CreateUUID {
	$uuidgen->create_str;
}

sub unloadByIDUser {
    my ($id, $user) = @_;
    $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};
}

sub UnloadModule {
    my ($cmod) = @_;
    unloadByIDUser($cmod->GetPerlID, $cmod->GetUser);
}

sub UnloadAll {
    while (my ($id, $pmod) = each %pmods) {
        unloadByIDUser($id, $pmod->{_cmod}->GetUser);
    }
}

sub IsModule {
	my $path = shift;
	my $modname = shift;
	my $f = IO::File->new($path);
	grep {/package\s+$modname\s*;/} <$f>;
}

sub LoadModule {
    my ($modname, $args, $user) = @_;
    $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 $modpath = ZNC::String->new;
    my $datapath = ZNC::String->new;
    ZNC::CModules::FindModPath("$modname.pm", $modpath, $datapath) or return ($ZNC::Perl_NotFound, "Unable to find module [$modname]");
    $modpath = $modpath->GetPerlStr;
	return ($ZNC::Perl_LoadError, "Incorrect perl module.") unless IsModule $modpath, $modname;
    require $modpath;
    my $id = CreateUUID;
	$datapath = $datapath->GetPerlStr;
	$datapath =~ s/\.pm$//;
    my $cmod = ZNC::CPerlModule->new($user, $modname, $datapath, $id);
	my %nv;
	tie %nv, 'ZNC::ModuleNV', $cmod;
    my $pmod = bless {
		_cmod=>$cmod,
		_nv=>\%nv
	}, $modname;
    $cmod->SetDescription($pmod->description);
    $cmod->SetArgs($args);
    $cmod->SetModPath($modpath);
    $pmods{$id} = $pmod;
    $user->GetModules->push_back($cmod);
    my $x = '';
    my $loaded = 0;
    eval {
        $loaded = $pmod->OnLoad($args, $x);
    };
	if ($@) {
		$x .= ' ' if '' ne $x;
		$x .= $@;
	}
    if (!$loaded) {
        unloadByIDUser($id, $user);
        if ($x) {
            return ($ZNC::Perl_LoadError, "Module [$modname] aborted: $x");
        }
        return ($ZNC::Perl_LoadError, "Module [$modname] aborted.");
    }
    if ($x) {
        return ($ZNC::Perl_Loaded, "Loaded module [$modname] [$x] [$modpath]");
    }
    return ($ZNC::Perl_Loaded, "Loaded module [$modname] [$modpath]")
}

sub GetModInfo {
    my ($modname) = @_;
    $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;
    ZNC::CModules::FindModPath("$modname.pm", $modpath, $datapath) or return ($ZNC::Perl_NotFound, "Unable to find module [$modname]");
    $modpath = $modpath->GetPerlStr;
	return ($ZNC::Perl_LoadError, "Incorrect perl module.") unless IsModule $modpath, $modname;
	require $modpath;
    my $pmod = bless {}, $modname;
    return ($ZNC::Perl_Loaded, $modpath->GetPerlStr, $pmod->description)
}

sub ModInfoByPath {
    my ($modpath, $modname) = @_;
	die "Incorrect perl module." unless IsModule $modpath, $modname;
    require $modpath;
    my $pmod = bless {}, $modname;
    return ($pmod->description)
}

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

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

sub CallSocket {
	my $modid = shift;
	$pmods{$modid}->_CallSocket(@_)
}

package ZNC::ModuleNV;

sub TIEHASH {
	my $name = shift;
	my $cmod = shift;
	bless {cmod=>$cmod, last=>-1}, $name
}

sub FETCH {
	my $self = shift;
	my $key = shift;
	return $self->{cmod}->GetNV($key) if $self->{cmod}->ExistsNV($key);
	return undef
}

sub STORE {
	my $self = shift;
	my $key = shift;
	my $value = shift;
	$self->{cmod}->SetNV($key, $value);
}

sub DELETE {
	my $self = shift;
	my $key = shift;
	$self->{cmod}->DelNV($key);
}

sub CLEAR {
	my $self = shift;
	$self->{cmod}->ClearNV;
}

sub EXISTS {
	my $self = shift;
	my $key = shift;
	$self->{cmod}->ExistsNV($key)
}

sub FIRSTKEY {
	my $self = shift;
	my @keys = $self->{cmod}->GetNVKeys;
	$self->{last} = 0;
	return $keys[0];
	return undef;
}

sub NEXTKEY {
	my $self = shift;
	my $last = shift;
	my @keys = $self->{cmod}->GetNVKeys;
	if ($#keys < $self->{last}) {
		$self->{last} = -1;
		return undef
	}
	# Probably caller called delete on last key?
	if ($last eq $keys[$self->{last}]) {
		$self->{last}++
	}
	if ($#keys < $self->{last}) {
		$self->{last} = -1;
		return undef
	}
	return $keys[$self->{last}]
}

sub SCALAR {
	my $self = shift;
	my @keys = $self->{cmod}->GetNVKeys;
	return $#keys + 1
}

package ZNC::Module;

sub description {
    "< Placeholder for a description >"
}

# Default implementations for module hooks. They can be overriden in derived modules.
sub OnLoad {1}
sub OnBoot {}
sub OnShutdown {}
sub WebRequiresLogin {}
sub WebRequiresAdmin {}
sub GetWebMenuTitle {}
sub OnWebPreRequest {}
sub OnWebRequest {}
sub GetSubPages {}
sub _GetSubPages { my $self = shift; $self->GetSubPages }
sub OnPreRehash {}
sub OnPostRehash {}
sub OnIRCDisconnected {}
sub OnIRCConnected {}
sub OnIRCConnecting {}
sub OnIRCRegistration {}
sub OnBroadcast {}
sub OnConfigLine {}
sub OnWriteUserConfig {}
sub OnWriteChanConfig {}
sub OnDCCUserSend {}
sub OnChanPermission {}
sub OnOp {}
sub OnDeop {}
sub OnVoice {}
sub OnDevoice {}
sub OnMode {}
sub OnRawMode {}
sub OnRaw {}
sub OnStatusCommand {}
sub OnModCommand {}
sub OnModNotice {}
sub OnModCTCP {}
sub OnQuit {}
sub OnNick {}
sub OnKick {}
sub OnJoin {}
sub OnPart {}
sub OnChanBufferStarting {}
sub OnChanBufferEnding {}
sub OnChanBufferPlayLine {}
sub OnPrivBufferPlayLine {}
sub OnClientLogin {}
sub OnClientDisconnect {}
sub OnUserRaw {}
sub OnUserCTCPReply {}
sub OnUserCTCP {}
sub OnUserAction {}
sub OnUserMsg {}
sub OnUserNotice {}
sub OnUserJoin {}
sub OnUserPart {}
sub OnUserTopic {}
sub OnUserTopicRequest {}
sub OnCTCPReply {}
sub OnPrivCTCP {}
sub OnChanCTCP {}
sub OnPrivAction {}
sub OnChanAction {}
sub OnPrivMsg {}
sub OnChanMsg {}
sub OnPrivNotice {}
sub OnChanNotice {}
sub OnTopic {}
sub OnServerCapAvailable {}
sub OnServerCapResult {}
sub OnTimerAutoJoin {}


# Functions of CModule will be usable from perl modules.
our $AUTOLOAD;

sub AUTOLOAD {
	my $name = $AUTOLOAD;
	$name =~ s/^.*:://; # Strip fully-qualified portion.
	my $sub = sub {
		my $self = shift;
		$self->{_cmod}->$name(@_)
	};
	no strict 'refs';
	*{$AUTOLOAD} = $sub;
	use strict 'refs';
	goto &{$sub};
}

sub DESTROY {}

sub BeginNV {
	die "Don't use BeginNV from perl modules, use GetNVKeys or NV instead!";
}
sub EndNV {
	die "Don't use EndNV from perl modules, use GetNVKeys or NV instead!";
}
sub FindNV {
	die "Don't use FindNV from perl modules, use GetNVKeys/ExistsNV or NV instead!";
}

sub NV {
	my $self = shift;
	$self->{_nv}
}

sub CreateTimer {
	my ($self, $job, $interval, $cycles, $description) = @_;
	my $id = ZNC::Core::CreateUUID;
	my $ctimer = ZNC::CreatePerlTimer($self->{_cmod}, $interval, $cycles, "perl-timer-$id", $description, $id);
	$self->{_ptimers}{$id}{job} = $job;
	$self->{_ptimers}{$id}{cobj} = $ctimer;
}

sub _CallTimer {
	my $self = shift;
	my $id = shift;
	&{$self->{_ptimers}{$id}{job}}($self, $self->{_ptimers}{$id}{obj});
}

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;
	$psock->Init(@_);
	$psock;
}

sub _CallSocket {
	my $self = shift;
	my $id = shift;
	my $func = shift;
	$self->{_sockets}{$id}->$func(@_)
}

package ZNC::Socket;

sub GetModule {
	my $self = shift;
	$ZNC::Core::pmods{$self->{_modid}};
}

sub Init {}
sub OnConnected {}
sub OnDisconnected {}
sub OnTimeout {}
sub OnConnectionRefused {}
sub OnReadData {}
sub OnReadLine {}
sub OnAccepted {}

sub _Accepted {
	my $self = shift;
	my $psock = $self->OnAccepted(@_);
	return $psock->{_csock} if defined $psock;
	return undef;
}

our $AUTOLOAD;

sub AUTOLOAD {
	my $name = $AUTOLOAD;
	$name =~ s/^.*:://; # Strip fully-qualified portion.
	my $sub = sub {
		my $self = shift;
		$self->{_csock}->$name(@_)
	};
	no strict 'refs';
	*{$AUTOLOAD} = $sub;
	use strict 'refs';
	goto &{$sub};
}

sub DESTROY {}

sub Connect {
	my $self = shift;
	my $host = shift;
	my $port = shift;
	my %arg = @_;
	$self->GetModule->GetManager->Connect(
			$host,
			$port,
			"perl-socket-".$self->GetPerlID,
			$arg{timeout}//60,
			$arg{ssl}//0,
			$arg{bindhost}//'',
			$self->{_csock}
			);
}

sub Listen {
	my $self = shift;
	my %arg = @_;
	my $addrtype = $ZNC::ADDR_ALL;
	if (defined $arg{addrtype}) {
		given ($arg{addrtype}) {
			when (/^ipv4$/i) { $addrtype = $ZNC::ADDR_IPV4ONLY }
			when (/^ipv6$/i) { $addrtype = $ZNC::ADDR_IPV6ONLY }
			when (/^all$/i)  { }
			default { die "Specified addrtype [$arg{addrtype}] isn't supported" }
		}
	}
	if (defined $arg{port}) {
		return $arg{port} if $self->GetModule->GetManager->ListenHost(
				$arg{port},
				"perl-socket-".$self->GetPerlID,
				$arg{bindhost}//'',
				$arg{ssl}//0,
				$arg{maxconns}//ZNC::_GetSOMAXCONN,
				$self->{_csock},
				$arg{timeout}//0,
				$addrtype
				);
		return 0;
	}
	$self->GetModule->GetManager->ListenRand(
			"perl-socket-".$self->GetPerlID,
			$arg{bindhost}//'',
			$arg{ssl}//0,
			$arg{maxconns}//ZNC::_GetSOMAXCONN,
			$self->{_csock},
			$arg{timeout}//0,
			$addrtype
			);
}

1