Perl Modules vs plugins

c0ncrete · #1 03-07-2018, 04:37 AM

A Perl module is sort of like a plugin, but is usable from anywhere you use Perl.

I suggest that you check out PPM for ActiveState's Perl distribution or CPAN for others (Strawberry, etc) if you have no idea what is happening here.

Understanding of OOP and namespace basics would be helpful as well.

This would go in <PERL_DIR>/site/lib/EQEmu/Database.pm
Part of this was shamelessly ganked from the existing plugin::LoadMysql().
You will need to have SQL::Statement installed for it to function.
You should already have everything else if you have a current install.

Code:

package EQEmu::Database;

use strict;
use warnings::register;
use Carp qw(confess);

use JSON;

use DBI;
use DBD::mysql;
use SQL::Statement;

sub new
{
    my $c = shift;
    my $p = length(@_) == 1 && ref $_[0] ? shift : {@_};
    $c->_initDone($p);
    return bless $p, $c;
}

sub _initDone
{
    my ($s, $p) = @_;
    my $c = ref $s || $s;
    foreach my $k (keys %{$p}) {
        next if $k =~ /^_/;
        warnings::warn("unhandled attribute [$k => $p->{$k}] in $c");
    }
}

# TODO: accept full path to config file as parameter
sub _loadConfig
{
	my ($self, $filepath) = @_;
	local $Carp::CarpLevel = $Carp::CarpLevel + 1;

	my $json = new JSON();

	# attempt to open and read entire file
	my $contents;
	open (my $fh, '<', $filepath)
	  or confess("cannot open config file [$filepath]"); {
		local $/;
		$contents = <$fh>;
	} close($fh);

	# decode the contents of the config file,
	# and only keep what we really need to
	my $config = $json->decode($contents)->{server}{database};

	$self->{_user} = $config->{username};
	$self->{_pass} = $config->{password};
	
	# construct and store DSN
	$self->{_dsn} = "DBI:mysql:$config->{db}:$config->{host}:3306";
}

# returns validated database handle
sub _getHandle
{
	my ($self) = @_;
	local $Carp::CarpLevel = $Carp::CarpLevel + 1;
	
	my $dbh = $self->{_dbh};
	unless ($dbh && (ref $dbh) =~ /^DBI::db$/) {
		warnings::warn("invalid database handle [".(ref $dbh)."]");
		return;
	};
	return $dbh;
}

# parses and validates SQL statement passed as string
# returns 0 or 1
sub _validateStatement
{
	my ($self, $inString) = @_;
	local $Carp::CarpLevel = $Carp::CarpLevel + 1;
	
	# get or create a parser (can be reused)
	my $parser;
	unless ($parser = $self->{_parser}) {
		$self->{_parser} = SQL::Parser->new();
		$parser = $self->{_parser};
	}
	
	# parse SQL statement for validation
	my $statement = SQL::Statement->new($inString, $parser);
	my $command   = $statement->command();
	
	# limit command type to SELECT for now
	unless ($command =~ /SELECT/) {
		warnings::warn("commands of type [".$command."] not allowed");
		return;
	}
	
	return 1
}

# connects database handle
sub Connect
{
	my ($self) = @_;
	local $Carp::CarpLevel = $Carp::CarpLevel + 1;

	warnings::warn("already connected... aborting attempt")
	  if $self->{_connected};

	$self->_loadConfig("F:\\EQEmu\\eqemu_config.json");
	
	my $dbh = DBI->connect(
		$self->{_dsn},
		$self->{_user},
		$self->{_pass}
	);
	unless ($dbh && (ref $dbh) =~ /^DBI::db$/) {
		confess("unable to create connection handle");
		return;
	}
	$self->{_dbh} = $dbh;
	$self->{_connected} = 1;

	return 1;
}

# verifies connection
sub Connected
{
	my ($self) = @_;
	local $Carp::CarpLevel = $Carp::CarpLevel + 1;
	
	return 0 unless $self->{_connected};
	
	my $dbh = $self->_getHandle
	  or confess("no database handle found");

	unless ($dbh->ping) {
		warnings::warn("unresponsive connection [ping]");
		$self->{_connected} = 0;
		$self->{_dbh} = undef;
		return;
	};
	
	return 1;
}

# returns an empty array reference on failure or empty result set
# otherwise, returns a reference to an array of hash references
sub Query {
	
	my ($self, $input) = @_;
	
	# validate SQL statement from input
	unless ($self->_validateStatement($input)) {
		warnings::warn("invalid SQL statement [".$input."]");
		return ();
	};
	
	# verify connection and get a database connection handle
	$self->Connect unless $self->Connected;
	return () unless my $dbh = $self->_getHandle;
	
	# basic DBI/DBD::MySQL stuff
	my $sth = $dbh->prepare($input);
	unless ($sth && (ref $sth) =~ /^DBI::st$/) {
		warnings::warn("invalid transaction handle [".(ref $sth)."]");
		return ();
	};
	$sth->execute;
	unless ($sth->rows) {
		warnings::warn("transaction returned no rows");
		return ();
	}
	
	return $sth->fetchall_arrayref({});
};

1;

This is an example of usage in a script.
I ran it outside the emulator for testing.

Note that I only called subroutines that did not begin with a _.
This is intentional as the idea behind a module (or plugin) is to simplify things for "high level" coding.

Code:

use EQEmu::Database;
use Data::Dump 'dump';

my $database = new EQEmu::Database();
   $database->Connect();

# the statement to execute
my $sql = "SELECT * FROM bot_data";

#where we will be storing everything
my $rows;

# execute the above statement if connected
if ($database->Connected()) {
	$rows = $database->Query($sql);
}

# dump all the data we got back
dump $rows;

# only print out specific information
my ($row, $key);
map {
	$row = $_;
	map {
		$key = $_;
		plugin::Debug("$key => $row->{$key}");
	} qw(bot_id name last_name race class owner_id);
} @$rows;

# access a specific field from the second row returned
plugin::Debug($$rows[1]->{last_spawn}); # = 1520152044

# emulates behavior of plugin::Debug() for testing
sub plugin::Debug {
	print "DEBUG: ".shift."\n";
}

c0ncrete · #2 03-07-2018, 06:26 AM

... and once you have access to data, you can build objects to consume it. You can make complex things simple and have code you can reuse anywhere. You can use it in a script that fires from an EVENT subroutine. You can use the same framework for a web interface for your website. Whatever is clever.

I guess this is as much a concept as a tutorial. It's the sort of thing that would make life easier for folks to understand what they can do with Perl in addition to other methods. They write books about this shit for a reason!

<PerlDir>\site\lib\EQEmu\Mob.pm

Code:

package EQEmu::Mob;

use strict;
use warnings::register;
use Carp qw(confess);

# construction
sub new
{
    my $c = shift;
    my $p = length @_ == 1 && ref $_[0] ? shift : {@_};
    # required parameters
    foreach ('name', 'class') {
        exists $p->{$_}
            or confess("$_ is a required attribute");
    }
    # validate and initialize these attributes
    my $_name   = delete $p->{name};
    my $_class  = delete $p->{class};
    my $_health = delete $p->{health} || 100;
    $p->{_name}   = $c->_validateName($_name);
    $p->{_class}  = $c->_validateClass($_class);
    $p->{_health} = $c->_validateHealth($_health);
    # set flags
    $p->{_isClient} = ($c =~ /^Client/) || 0;
    $p->{_isBot}    = ($c =~ /^Bot/)    || 0;
    $p->{_isNPC}    = ($c =~ /^NPC/)    || 0;
    $c->_initDone($p) if $c =~ /^Mob/;
    return bless $p, $c;
}
sub _initDone
{
    my ($s, $p) = @_;
    my $c = ref $s || $s;
    foreach my $k (keys %{$p}) {
        next if $k =~ /^_/;
        warnings::warn("unhandled attribute [$k => ".$p->{$k}."] in $c");
    }
}

sub _validateName
{
    my ($self, $name) = @_;
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    $name =~ /^#?[a-z_]*$/i
        or confess("invalid name [$name]");
    return $name;
}
sub _validateClass
{
    my ($self, $class) = @_;
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    $class ~~ [1..16]  ||
    $class ~~ [20..35] ||
    $class ~~ [40..41] ||
    $class ~~ [59..64] ||
    $class ~~ [67..71]
        or confess("invalid class [$class]");
    return $class;
}
sub _validateHealth
{
    my ($self, $health) = @_;
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    $health ~~ [0..100]
        or confess("invalid health % [$health]");
    return $health;
}

sub GetClass
{
    shift->{_class};
}
sub GetCleanName
{
    shift->{_name};
}
sub IsBot
{
    shift->{_isBot};
}
sub IsClient
{
    shift->{_isClient};
}
sub IsNPC
{
    shift->{_isNPC};
}
sub GetHPRatio
{
    shift->{_health};
}
sub GetGroup
{
    return 0;
}

1;

c0ncrete · #3 03-07-2018, 06:51 AM

I knew more about all this crap when I wrote it.
This is an indication of how long ago that was...

Code:

package EQEmu::PlayerProfile_Struct;

use strict;
use warnings;

use EQEmu::BlobConvert;
use EQEmu::Bind_Struct;
use EQEmu::Color_Struct;

# constructor
sub new {
    my ($class, %params) = @_;
    my $self = {};
    bless ($self, $class);
    foreach my ($key, $val) (%params) {
        print "$key => $val.\n";
    }
    $self->parseBlob($blob);
    $self;
}

# data extraction/conversion happens here
sub parseBlob {
    my ($self, $blob) = @_;
    $self->{_checksum}    = asc2dec($blob,   0,  4);
    $self->{_name}        = asconly($blob,   4, 64);
    $self->{_last_name}   = asconly($blob,  68, 32);
    $self->{_gender}      = asc2dec($blob, 100,  4);
    $self->{_race}        = asc2dec($blob, 104,  4);
    $self->{_class_}      = asc2dec($blob, 108,  4);
    $self->{_unknown0112} = asc2dec($blob, 112,  4);
    $self->{_level}       = asc2dec($blob, 116,  4);
    foreach my $i (0..4) {
        $self->{_binds}[$i] = new EQEmu::Bind_Struct
        (
              asc2dec($blob, $i*20+120, 4), # zoneID
            asc2float($blob, $i*20+124, 4), # x
            asc2float($blob, $i*20+128, 4), # y
            asc2float($blob, $i*20+132, 4), # z
            asc2float($blob, $i*20+136, 4)  # heading
        );
    }
    $self->{_haircolor}        = asc2dec($blob,  296, 1);
    $self->{_beardcolor}       = asc2dec($blob,  297, 1);
    $self->{_eyecolor1}        = asc2dec($blob,  298, 1);
    $self->{_eyecolor2}        = asc2dec($blob,  299, 1);
    $self->{_hairstyle}        = asc2dec($blob,  300, 1);
    $self->{_beard}            = asc2dec($blob,  301, 1);
    $self->{_face}             = asc2dec($blob, 2504, 1);
    $self->{_drakkin_heritage} = asc2dec($blob, 5440, 4);
    $self->{_drakkin_tattoo}   = asc2dec($blob, 5444, 4);
    $self->{_drakin_details}   = asc2dec($blob, 5448, 4);
    foreach my $i (0..8) {
        $self->{_item_material}[$i] = asc2dec($blob, $i*4+312, 4);
    }
    foreach my $i (0..8) {
        $self->{_item_tint}[$i] = new EQEmu::Color_Struct
        (
            asc2dec($blob, $i*4+396, 1), # blue
            asc2dec($blob, $i*4+397, 1), # green
            asc2dec($blob, $i*4+398, 1), # red
            asc2dec($blob, $i*4+399, 1)  # use_tint
        );
    }
}

# read-only accessor methods
# array accessors return the specified element if an index is passed
# otherwise, the entire array is returned
sub checksum         { shift->{_checksum}; }
sub name             { shift->{_name}; }
sub last_name        { shift->{_last_name}; }
sub gender           { shift->{_gender}; }
sub race             { shift->{_race}; }
sub class_           { shift->{_class_}; }
sub level            { shift->{_level}; }
sub haircolor        { shift->{_haircolor}; }
sub beardcolor       { shift->{_beardcolor}; }
sub eyecolor1        { shift->{_eyecolor1}; }
sub eyecolor2        { shift->{_eyecolor2}; }
sub hairs            { shift->{_hairstyle}; }
sub beard            { shift->{_beard}; }
sub face             { shift->{_face}; }
sub drakkin_heritage { shift->{_drakkin_heritage}; }
sub drakkin_tattoo   { shift->{_drakkin_tattoo}; }
sub drakkin_details  { shift->{_drakkin_details}; }
sub item_material {
    my ($self, $i) = @_;
    defined($i) ? ${$self->{_item_material}}[$i] : @{$self->{_item_material}};
}
sub binds {
    my ($self, $i) = @_;
    defined($i) ? ${$self->{_binds}}[$i] : @{$self->{_binds}};
}
sub item_tint {
    my ($self, $i) = @_;
    defined($i) ? ${$self->{_item_tint}}[$i] : @{$self->{_item_tint}};
}

1;