Games-Axmud
view release on metacpan or search on metacpan
lib/Games/Axmud/Generic.pm view on Meta::CPAN
@packageList = split(m/\./, $name);
if ((scalar @packageList) > 1) {
$msg = pop @packageList;
}
# Decode the JSON data. I'm still not sure what data format is allowed under ATCP (and
# neither is anyone else, apparently), so if ATCP isn't obviously in a JSON format, I'll
# enclose it in quotes to prevent GA::Client->decodeJson from throwing up an error
if ($class eq 'Games::Axmud::Obj::Atcp') {
if ($origData =~ m/^[^\{\}\[\]\:]*$/) {
$origData = '"' . $origData . '"';
}
}
$data = $axmud::CLIENT->decodeJson($origData);
if (! defined $data) {
return undef;
}
# Setup
my $self = {
_objName => $name,
_objClass => $class,
_parentFile => $session->currentWorld->name,
_parentWorld => undef,
_privFlag => FALSE, # All IVs are public
# IVs
# ---
# The name of the ATCP/GMCP module, a string in the form
# 'Package[.SubPackages][.Message]'
name => $name,
# The components of $name - a list of package components, and the message (e.g.
# 'Foo.Bar.Baz' produces a package component list of 2 items ('Foo', 'Bar') and a
# scalar message 'Baz'
packageList => \@packageList,
msg => $msg,
# The ATCP/GMCP data itself. The original data string, a scalar of undecoded JSON data,
# e.g. 'comm.repop { "zone": "town" }'. This string is not updated when $self->data
# is updated
origData => $origData,
# The interpreted JSON data. The key's corresponding value can be a scalar, or a
# list/hash reference, with further list/hash references embedded within
data => $data,
};
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub update {
# Called by GA::Session->processAtcpData and ->processGmcpData
# Replaces the JSON data stored in $self->data with the new ATCP/GMCP package's data,
# merging embedded hashes but replacing embedded scalars and lists
#
# Expected arguments
# $jsonScalar - A scalar of undecoded JSON data, e.g. '{ "zone": "town" }'
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $jsonScalar, $check) = @_;
# Local variables
my $newData;
# Check for improper arguments
if (! defined $jsonScalar || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->update', @_);
}
# As described in ->new, ATCP must be handled with kid gloves
if ($self->isa('Games::Axmud::Obj::Atcp')) {
if ($jsonScalar =~ m/^[^\{\}\[\]\:]*$/) {
$jsonScalar = '"' . $jsonScalar . '"';
}
}
$newData = $axmud::CLIENT->decodeJson($jsonScalar);
$self->{data} = $self->update_scalar($newData, $self->{data});
return 1;
}
sub update_scalar {
# Called by $self->update and by this function recursively
# Replaces the JSON data stored in $self->data with the new ATCP/GMCP package's data,
# merging embedded hashes but replacing embedded scalars and lists
#
# Expected arguments
# (none besides $self)
#
# Optional arguments
# $newScalar - A scalar (might be a list/hash reference, might be embedded within other
# list/hash references) from the recently-received ATCP/GMCP package's
# data. If 'undef', the scalar was (probably) a JSON null value
# $oldScalar - The corresponding scalar in the previously-received ATCP/GMCP package's
# data. If 'undef', the scalar was (probably) a JSON null value
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $newScalar, $oldScalar, $check) = @_;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->update_scalar', @_);
}
if (
defined $newScalar
&& ref $newScalar eq 'HASH'
&& defined $oldScalar
&& ref $oldScalar eq 'HASH'
) {
# (Merge the hashes, and return the combined hash
foreach my $key (keys %$newScalar) {
if (! exists $$oldScalar{$key}) {
$$oldScalar{$key} = $$newScalar{$key};
} else {
$$oldScalar{$key} = $self->update_scalar($$newScalar{$key}, $$oldScalar{$key});
}
}
return $oldScalar;
} else {
# (Scalar or list reference replaces the old scalar or list reference)
return $newScalar;
}
}
##################
# Accessors - set
##################
# Accessors - get
lib/Games/Axmud/Generic.pm view on Meta::CPAN
'/' => 'kp_divide',
'slash' => 'kp_divide',
'divide' => 'kp_divide',
'kp_divide' => 'kp_divide',
'.' => 'kp_full_stop',
'dot' => 'kp_full_stop',
'fullstop' => 'kp_full_stop',
'period' => 'kp_full_stop',
'kp_full_stop' => 'kp_full_stop',
'enter' => 'kp_enter',
'return' => 'kp_enter',
'kp_enter' => 'kp_enter',
);
# Hash of other keypad <key>s that the Compass task doesn't allow us to customise
%otherHash = (
1 => '1',
2 => '2',
3 => '3',
4 => '4',
6 => '6',
7 => '7',
8 => '8',
9 => '9',
'one' => '1',
'two' => '2',
'three' => '3',
'four' => '4',
'six' => '6',
'seven' => '7',
'eight' => '8',
'nine' => '9',
'kp_1' => '1',
'kp_2' => '2',
'kp_3' => '3',
'kp_4' => '4',
'kp_6' => '6',
'kp_7' => '7',
'kp_8' => '8',
'kp_9' => '9',
'+' => 'add',
'plus' => 'add',
'add' => 'add',
'kp_add' => 'add',
'-' => 'subtract',
'minus' => 'subtract',
'subtract' => 'subtract',
'kp_subtract' => 'subtract',
);
return (\%hash, \%otherHash);
}
sub updateCompass {
# Called by GA::Cmd::PermCompass->do and WorldCompass->do
# Applies changes to the IVs for a global initial task or the current world's initial task
#
# Expected arguments
# $session, $inputString, $standardCmd
# - Standard arguments to a command's ->do function
# $argListRef - Reference to the list of arguments supplied to the client command
# (unmodified). The calling function has already checked there is at
# least one argument
# $currentListRef - Reference to a list of current tasklist tasks (should contain 0 or 1
# items)
# $initListRef - Reference to a list of initial tasks (can contain any number of items,
# including 0)
#
# Return values
# 'undef' on improper arguments or failure
# 1 on success
my (
$self, $session, $inputString, $standardCmd, $argListRef, $currentListRef, $initListRef,
$check,
) = @_;
# Local variables
my (
$hashRef, $otherHashRef, $count, $errorCount, $key, $keycode, $cmd,
@args, @taskList, @initTaskList,
%hash, %otherHash,
);
# Check for improper arguments
if (
! defined $session || ! defined $inputString || ! defined $standardCmd
|| ! defined $argListRef || ! defined $currentListRef || ! defined $initListRef
|| defined $check
) {
return $axmud::CLIENT->writeImproper(
$self->_objClass . '->updateCompass',
@_,
);
}
# Dereference the args
@args = @$argListRef;
@taskList = @$currentListRef;
@initTaskList = @$initListRef;
# %hash to convert all the <key>s that the Compass task allows us to customise
# %otherHash of other keypad <key>s that the Compass task doesn't allow us to customise
($hashRef, $otherHashRef) = $self->getKeypadHashes();
%hash = %$hashRef;
%otherHash = %$otherHashRef;
# Count successes and errors, to show in confirmation messages
$count = 0;
$errorCount = 0;
# ;pcm on
# ;pcm -o
lib/Games/Axmud/Generic.pm view on Meta::CPAN
sub modifyEditHash_hashIV {
# Can be called by anything
# Adds (or replaces) a single key-value pair in a hash IV, and saves the whole hash IV
# If this IV hasn't been modified yet - i.e., if it is stored in $self->editObj but not in
# $self->editHash, the hash is copied from $self->editObj, modified, then saved to
# $self->editHash
#
# Expected arguments
# $iv - The IV to be checked; a key in $self->editHash or an IV in
# $self->editObj
# $key, $value - The key/value pair to replace ($value can be 'undef')
#
# Optional arguments
# $deleteFlag - If set to TRUE, the key-value pair is deleted from the hash ($value is
# ignored, and should be set to 'undef')
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $iv, $key, $value, $deleteFlag, $check) = @_;
# Local variables
my %ivHash;
# Check for improper arguments
if (! defined $iv || ! defined $key || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->modifyEditHash_hashIV', @_);
}
# Import the hash from $self->editHash if it's there, or the original hash from
# $self->editObj otherwise
if ($self->ivExists('editHash', $iv)) {
%ivHash = $self->getEditHash_hashIV($iv);
} else {
%ivHash = $self->editObj->$iv;
}
if ($deleteFlag) {
# Delete the key-value pair
if (exists $ivHash{$key}) {
delete $ivHash{$key};
}
} else {
# Add the key-value pair
$ivHash{$key} = $value;
}
# Save the modified hash
$self->ivAdd('editHash', $iv, \%ivHash);
return 1;
}
sub updateListDataWithKey {
# Can be called by any tab function to update the data in a GA::Obj::SimpleList when it is
# storing data in two columns representing the contents of a hash
# The first column is the key, the second column its corresponding value
# If the key already exists in the list, it is replaced; otherwise a new key-value pair is
# added to the simple list
# If the key is not defined or an empty string, it isn't added to the simple list
#
# Expected arguments
# $slWidget - The GA::Obj::SimpleList to modify
# $key - The key to add to the list, which will eventually be stored as a hash
# $value - Its corresponding value
#
# Return values
# 'undef' on improper arguments, or if $key is 'undef' or an empty string
# 1 otherwise
my ($self, $slWidget, $key, $value, $check) = @_;
# Local variables
my (
@list,
%hash,
);
# Check for improper arguments
if (! defined $slWidget || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateListDataWithKey', @_);
}
# If $key is 'undef' or an empty string, do nothing
if (! $key) {
return undef;
}
# Convert the data stored in the GA::Obj::SimpleList into a hash
%hash = $self->convertListDataToHash($slWidget);
# Add the key-value pair
$hash{$key} = $value;
# Get a list of keys in the hash, so we can sort it alphabetically
@list = sort {lc($a) cmp lc($b)} (keys %hash);
# Reset the GA::Obj::SimpleList
@{$slWidget->{data}} = ();
foreach my $sortedKey (@list) {
push (@{$slWidget->{data}}, [$sortedKey, $hash{$sortedKey}]);
}
return 1;
}
sub findKeyInListData {
# Can be called by any tab function to check the data in a GA::Obj::SimpleList when it is
lib/Games/Axmud/Generic.pm view on Meta::CPAN
return $self->error(
'The \'' . $self->name . '\' task was created by a plugin which has been'
. ' disabled',
);
}
}
# Otherwise, the task can be added to a current, initial or custom tasklist
return 1;
}
sub setParentFileObj {
# Called by a task's ->new function (but not by the generic task itself))
# Sets the standard IVs ->_parentFile and ->_parentWorld, if required
#
# Expected arguments
# $session - The calling function's GA::Session
# $taskType - Which tasklist this task is being created into - 'current', 'initial'
# or 'custom'
#
# Optional arguments
# $profName - Name of the profile in whose initial tasklist this task will be (or
# 'undef')
# $profCategory - That profile's category (or 'undef')
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $session, $taskType, $profName, $profCategory, $check) = @_;
# Check for improper arguments
if (! defined $session || ! defined $taskType || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->setParentFileObj', @_);
}
# Initial task in a profile's initial tasklist
if ($taskType eq 'initial' && defined $profName) {
if ($profCategory eq 'world') {
$self->{_parentFile} = $profName;
} else {
$self->{_parentFile} = 'otherprof';
$self->{_parentWorld} = $session->currentWorld->name;
}
# Task in the global initial/custom tasklists
} elsif ($taskType eq 'initial' || $taskType eq 'custom') {
$self->{_parentFile} = 'tasks';
}
return 1;
}
sub updateTaskLists {
# Called by a task's ->new function (but not by the generic task itself))
# Also called by GA::Obj::File->extractData when importing an initial/custom task
#
# Updates the current, global initial, custom or profile initial tasklists with the newly-
# created task, as appropriate. Also sets $self->uniqueName
# NB We use $self->{...} to set the value of IVs, rather than $self->ivPoke(...), to avoid
# setting the ->modifyFlag IV of parent GA::Obj::File (stored in $self->_parentFile)
#
# Expected arguments
# $session - The calling function's GA::Session (set as an IV for current tasks only)
#
# Return values
# 'undef' on improper arguments or if we try to add a non-storable task to an initial or
# custom tasklist
# 1 otherwise
my ($self, $session, $check) = @_;
# Local variables
my $profile;
# Check for improper arguments
if (! defined $session || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateTaskLists', @_);
}
if ($self->taskType eq 'current') {
# Give task a unique name within the current tasklist
$self->{uniqueName} = $self->{name} . '_' . $axmud::CLIENT->inc_taskTotal();
# Set the session to which this current task will belong
$self->{session} = $session;
# Create an entry in the session's current tasklist
$session->add_task($self);
} else {
# If ->storableFlag is not set, the task can't be added to any initial/custom tasklist
if (! $self->storableFlag) {
return $self->writeError(
'\'' . $self->prettyName . '\' task cannot be added as an initial/custom task',
$self->_objClass . '->updateTaskLists',
);
} elsif ($self->taskType eq 'initial') {
if (! defined $self->profName) {
# Give task a unique name within the global initial tasklist
$self->{uniqueName}
= $self->{name} . '_' . $axmud::CLIENT->inc_initTaskTotal();
# Create an entry in the global initial tasklist
$axmud::CLIENT->add_initTask($self);
} else {
# Give task a unique name within the associated profile's initial tasklist
lib/Games/Axmud/Generic.pm view on Meta::CPAN
});
$nextButton->set_tooltip_text('Move on to the next page');
# Create the Previous button
my $prevButton = Gtk3::Button->new('Previous');
$hBox->pack_end($prevButton, FALSE, FALSE, $self->spacingPixels);
$prevButton->get_child->set_width_chars(10);
$prevButton->signal_connect('clicked' => sub {
$self->buttonPrevious();
});
$prevButton->set_tooltip_text('Go back to the previous page');
$prevButton->set_sensitive(FALSE); # Because 1st page is showing, starts desensitised
# Create the Cancel button
my $cancelButton = Gtk3::Button->new('Cancel');
$hBox->pack_start($cancelButton, FALSE, FALSE, $self->borderPixels);
$cancelButton->get_child->set_width_chars(10);
$cancelButton->signal_connect('clicked' => sub {
$self->buttonCancel();
});
$cancelButton->set_tooltip_text('Cancel changes and close this window');
return ($nextButton, $prevButton, $cancelButton);
}
sub setupGrid {
# Called by $self->winEnable
# Creates the first page for the wizard (not really necessary to have a whole function
# dedicated to this task, but having one keeps the design of 'wiz' windows consistent
# with the design of 'edit'/'pref' windows)
#
# Expected arguments
# (none besides $self)
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $check) = @_;
# Local variables
my ($func, $rows);
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->setupGrid', @_);
}
# Get the name of the function for the first page
$func = $self->ivIndex('pageList', $self->currentPage) . 'Page';
# Call the function
$rows = $self->$func();
return 1;
}
sub updateGrid {
# Called by $self->buttonPrevious and ->buttonNext
# Changes the page currently visible in the 'wiz' window
#
# Expected arguments
# (none besides $self)
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $check) = @_;
# Local variables
my ($func, $rows);
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateGrid', @_);
}
# Empty the grid used for the existing page
foreach my $widget ($self->grid->get_children()) {
$axmud::CLIENT->desktopObj->removeWidget($self->grid, $widget);
}
# Get the name of the function for the new current page
$func = $self->ivIndex('pageList', $self->currentPage) . 'Page';
# Call the function
$rows = $self->$func();
# Set button sensititives ($self->disableNextButtonFlag, etc, override the usual rules, if
# they are set)
# If it's the first page, the 'Previous' button must not be sensitive
if ($self->currentPage == 0) {
$self->previousButton->set_sensitive(FALSE);
if (! $self->disableNextButtonFlag) {
$self->nextButton->set_sensitive(TRUE);
} else {
$self->nextButton->set_sensitive(FALSE);
}
# Make sure the 'Next' button has the right label
$self->nextButton->set_label('Next');
$self->nextButton->get_child->set_width_chars(10);
# If it's the last page, the 'Next' button must be converted to a 'Finish' button
} elsif ($self->currentPage >= ((scalar $self->pageList) - 1)) {
if (! $self->disablePreviousButtonFlag) {
$self->previousButton->set_sensitive(TRUE);
} else {
$self->previousButton->set_sensitive(FALSE);
}
( run in 2.522 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )