Games-Axmud
view release on metacpan or search on metacpan
lib/Games/Axmud/Generic.pm view on Meta::CPAN
# Get a list of profiles, and remove anything that's not the right category
foreach my $obj ($session->ivValues('profHash')) {
if ($obj->category eq $category) {
push (@profList, $obj);
}
}
# Sort the list
@sortedList = sort {lc($a->name) cmp lc($b->name)} (@profList);
if (! @sortedList) {
return $self->complete(
$session, $standardCmd,
'The ' . $category . ' profile list is empty',
);
}
# Display header
$session->writeText(
'List of ' . $category . ' profiles (* = current ' . $category . ')',
);
# Display list
foreach my $obj (@sortedList) {
my $column;
if (
$session->ivExists('currentProfHash', $category)
&& $session->ivShow('currentProfHash', $category) eq $obj
) {
$column = ' * ';
} else {
$column = ' ';
}
$self->writeText($column . sprintf('%-16.16s', $obj->name));
}
# Display footer
if (@sortedList == 1) {
return $self->complete(
$session, $standardCmd,
'End of list (1 ' . $category . ' profile found)',
);
} else {
return $self->complete(
$session, $standardCmd,
'End of list (' . scalar @sortedList . ' ' . $category . ' profiles found)',
);
}
}
sub addInterface {
# Called by GA::Cmd::AddTrigger->do, AddAlias->do, AddMacro->do, AddTimer->do and
# AddHook->do
# (For the whole of this function, 'trigger' is taken to mean any of 'trigger', 'alias',
# 'macro', 'timer' or 'hook')
#
# This function adds an independent trigger to a trigger cage in response to the client
# command ';addtrigger'
# Unless there is a superior cage with a trigger of the same name, also adds an active
# trigger interface to the GA::Session's registry of active interfaces. In that case, if
# there is an inferior cage with a trigger of the same name, the corresponding active
# interface (if any) is destroyed. As a result, there will be exactly one active trigger
# interface with this name
#
# Expected arguments
# $session - The calling function's GA::Session
# $inputString - The command actually typed, e.g. 'atr -s pattern -p instruction'
# $standardCmd - Standard version of the client command, e.g. 'addtrigger'
# $category - 'trigger', 'alias', 'macro', 'timer', 'hook'
# $categoryPlural - e.g. 'triggers'
# $modelObj - The interface model object corresponding to $category
# @args - The arguments specified by the user in the ';addtrigger' command
#
# Return values
# 'undef' on improper arguments or if there's an error
# 1 on success
my (
$self, $session, $inputString, $standardCmd, $category, $categoryPlural, $modelObj,
@args,
) = @_;
# Local variables
my (
$switch, $name, $value, $attribCount, $matchCount, $failFlag, $result, $profCategory,
$profName, $profCount, $newObj, $newObjName, $proposedName, $cage, $package, $dummyObj,
$newStimulus, $newResponse, $exitFlag,
@superiorList, @inferiorList,
%attribHash, %optionalAttribHash, %beforeHash, %afterHash,
);
# Check for improper arguments
if (
! defined $session || ! defined $inputString || ! defined $standardCmd
|| ! defined $category || ! defined $categoryPlural || ! defined $modelObj || ! @args
) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->addInterface', @_);
}
# Extract group 4 (optional) switch options
do {
$exitFlag = TRUE;
($switch, $name, @args) = $self->extract('-b', 1, @args);
if (defined $switch) {
$exitFlag = FALSE; # Allow the loop to repeat, looking for more -b switches
if (! defined $name) {
return $self->error(
lib/Games/Axmud/Generic.pm view on Meta::CPAN
$result = $newObj->set_beforeAfterHashes($session, \%beforeHash, \%afterHash);
if (! $result) {
return $self->error(
$session, $inputString,
'Invalid before/after interfaces',
);
}
}
}
# Tell the trigger cage that it has received a new trigger
$cage->ivAdd('interfaceHash', $newObj->name, $newObj);
# Get a list of profiles with higher priority than this one
@superiorList = $session->findSuperiorList($profCategory);
# Get a list of profiles with lower priority than this one
@inferiorList = $session->findInferiorList($profCategory);
# Check whether there are any triggers with the same name, belonging to a cage associated
# with a superior profile to this cage's profile. If none, create an interface for the
# trigger
# Also, if there is a trigger, with the same name but belonging to a cage associated with an
# inferior profile to this cage's profile, destroy its interface
# As a result, there should be exactly one interface for a trigger with this name, no matter
# how many triggers with that name exist
$result = $session->injectInterface(
$newObj,
$newObjName,
$profName,
\@superiorList,
\@inferiorList,
);
if (! $result) {
return $self->error(
$session, $inputString,
'General error creating ' . $category . ' \'' . $newObjName . '\'',
);
} elsif ($result == 1) {
return $self->complete(
$session, $standardCmd,
'Active ' . $category . ' interface \'' . $newObjName . '\' created',
);
} else {
return $self->complete(
$session, $standardCmd,
'Inactive ' . $category . ' interface \'' . $newObjName . '\' created',
);
}
}
sub modifyInterface {
# Called by GA::Cmd::ModifyTrigger->do, ModifyAlias->do, ModifyMacro->do,
# ModifyTimer->do and ModifyHook->do
# (For the whole of this function, 'trigger' is taken to mean any of 'trigger', 'alias',
# 'macro', 'timer' or 'hook')
#
# This function modifies the attributes of an independent trigger stored in a trigger
# cage. If there's a corresponding active interface, it is also modified
#
# This function can also be called to modify an active interface directly, without
# changing the corresponding independent trigger stored in a trigger cage (if any)
#
# Expected arguments
# $session - The calling function's GA::Session
# $inputString - The command actually typed, e.g. 'mtr -s pattern -p instruction'
# $standardCmd - Standard version of the client command, e.g. 'modifytrigger'
# $category - 'trigger', 'alias', 'macro', 'timer', 'hook'
# $categoryPlural - e.g. 'triggers'
# $modelObj - The interface model object corresponding to $category
# @args - The arguments specified by the user in the ';modifytrigger' command
#
# Return values
# 'undef' on improper arguments or if there's an error
# 1 on success
my (
$self, $session, $inputString, $standardCmd, $category, $categoryPlural, $modelObj,
@args,
) = @_;
# Local variables
my (
$switch, $value, $attribCount, $profCount, $profCategory, $profName, $interface,
$interfaceObj, $result, $currentObj, $currentObjName, $cage, $exitFlag, $name,
%beforeHash, %afterHash, %beforeRemoveHash, %afterRemoveHash, %attribHash,
);
# Check for improper arguments
if (
! defined $session || ! defined $inputString || ! defined $standardCmd
|| ! defined $category || ! defined $categoryPlural || ! defined $modelObj || ! @args
) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->modifyInterface', @_);
}
# Extract group 4 (optional) switch options
do {
$exitFlag = TRUE;
($switch, $name, @args) = $self->extract('-b', 1, @args);
if (defined $switch) {
$exitFlag = FALSE; # Allow the loop to repeat, looking for more -b switches
if (! defined $name) {
return $self->error(
$session, $inputString,
ucfirst($category) . ' interface not created - missing name',
);
lib/Games/Axmud/Generic.pm view on Meta::CPAN
. $currentObj->name . '\'',
);
}
}
# Modify the before/after hashes, if specified
if (%beforeHash || %afterHash || %beforeRemoveHash || %afterRemoveHash) {
$result = $currentObj->set_beforeAfterHashes(
$session,
\%beforeHash, \%afterHash,
\%beforeRemoveHash, \%afterRemoveHash,
);
if (! $result) {
return $self->error(
$session, $inputString,
'Failed to modify the ' . $category . ' interface \''
. $currentObj->name . '\'',
);
}
}
# If there's an active interface based upon this interface object, we need to update the
# active interface, too. We must do this in every session that shares the same world
# Do the update in every affected session, except this one
foreach my $otherSession ($axmud::CLIENT->listSessions()) {
if (
$otherSession->currentWorld eq $session->currentWorld
&& $otherSession ne $self
) {
$otherSession->updateInterfaces($currentObj, %attribHash);
}
}
# Now apply to this session
if (! $session->updateInterfaces($currentObj, %attribHash)) {
return $self->complete(
$session, $standardCmd,
ucfirst($category) . ' interface \'' . $currentObj->name . '\' modified, but'
. ' but general error while modifying the corresponding active interface(s)',
);
} else {
# There is no active interface based on this trigger (etc)
return $self->complete(
$session, $standardCmd,
'Inactive ' . $category . ' interface \'' . $currentObjName . '\' modified',
);
}
}
}
sub exportInterface {
# Called by GA::Cmd::ExportTrigger->do, ExportAlias->do, ExportMacro->do,
# ExportTimer->do and ExportHook->do
# (For the whole of this function, 'trigger' is taken to mean any of 'trigger', 'alias',
# 'macro', 'timer' or 'hook')
#
# This function adds an inactive trigger, stored in a trigger cage, to Axmud's interface
# clipboard, from where it can 'imported' to a different cage (perhaps in a different
# world, in a different session)
# This function can also be called to export an active interface directly, without
# exporting the corresponding inactive trigger stored in a trigger cage (if any)
#
# Expected arguments
# $session - The calling function's GA::Session
# $inputString - The command actually typed, e.g. 'etr mytrigger'
# $standardCmd - Standard version of the client command, e.g. 'exporttrigger'
# $category - 'trigger', 'alias', 'macro', 'timer', 'hook'
# $categoryPlural - e.g. 'triggers'
# $modelObj - The interface model object corresponding to $category
# @args - The arguments specified by the user in the ';exporttrigger' command
#
# Return values
# 'undef' on improper arguments or if there's an error
# 1 on success
my (
$self, $session, $inputString, $standardCmd, $category, $categoryPlural, $modelObj,
@args,
) = @_;
# Local variables
my (
$profCount, $profCategory, $profName, $switch, $interface, $interfaceObj,
$currentObjName, $cage, $currentObj,
);
# Check for improper arguments
if (
! defined $session || ! defined $inputString || ! defined $standardCmd
|| ! defined $category || ! defined $categoryPlural || ! defined $modelObj || ! @args
) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->exportInterface', @_);
}
# Extract profile (group 1) switch options
($profCount, $profCategory, $profName, @args) = $self->extractProfileSwitches(
$session,
$inputString,
$category,
'export',
@args,
);
if (! defined $profCount) {
# Error in ->extractProfileSwitches - error message already displayed
return undef;
}
# Extract active interface (group 0) switch options
($switch, $interface, @args) = $self->extract('i', 1, @args);
if (defined $switch) {
lib/Games/Axmud/Generic.pm view on Meta::CPAN
# Find the cage matching the specified profile
$cage = $session->findCage($category, $profName);
if (! $cage) {
return $self->error(
$inputString,
'Can\'t export ' . $category . ' interface because the ' . $category
. ' cage for \'' . $profName . '\' is missing',
);
}
# Check that the cage has a trigger with this name
if (! $cage->ivExists('interfaceHash', $currentObjName)) {
if ($category eq 'alias') {
return $self->error(
$session, $inputString,
'Can\'t export alias interface because the alias cage doesn\'t'
. 'have an alias with the name \'' . $currentObjName
. '\'',
);
} else {
return $self->error(
$session, $inputString,
'Can\'t export ' . $category . ' interface because the ' . $category
. ' cage doesn\'t have a ' . $category . ' with the name \''
. $currentObjName .'\'',
);
}
} else {
# Get the blessed reference of the trigger object (but don't consult inferior cages)
$currentObj = $cage->ivShow('interfaceHash', $currentObjName);
if (! $currentObj) {
return $self->error(
$session, $inputString,
'General error exporting the ' . $category . ' interface object \''
. $currentObjName . '\'',
);
}
}
# Export the interface
$axmud::CLIENT->add_interfaceClipboardList($currentObj);
return $self->complete(
$session, $standardCmd,
'Inactive ' . $category . ' interface \'' . $currentObjName . '\' exported to the'
. ' interface clipboard',
);
}
}
sub importInterface {
# Called by GA::Cmd::ImportTrigger->do, ImportAlias->do, ImportMacro->do,
# ImportTimer->do and ImportHook->do
# (For the whole of this function, 'trigger' is taken to mean any of 'trigger', 'alias',
# 'macro', 'timer' or 'hook')
#
# This function clones all triggers in Axmud's interface clipboard, moving the copies into
# the specified cage.
#
# Expected arguments
# $session - The calling function's GA::Session
# $inputString - The command actually typed, e.g. 'itr mytrigger'
# $standardCmd - Standard version of the client command, e.g. 'importtrigger'
# $category - 'trigger', 'alias', 'macro', 'timer', 'hook'
# $categoryPlural - e.g. 'triggers'
# $modelObj - The interface model object corresponding to $category
#
# Optional arguments
# @args - The arguments specified by the user in the ';importtrigger' command
#
# Return values
# 'undef' on improper arguments or if there's an error
# 1 on success
my (
$self, $session, $inputString, $standardCmd, $category, $categoryPlural, $modelObj,
@args,
) = @_;
# Local variables
my (
$profCount, $profCategory, $profName, $cage, $failCount, $successCount, $newObj,
$result,
@interfaceList, @superiorList, @inferiorList,
);
# Check for improper arguments
if (
! defined $session || ! defined $inputString || ! defined $standardCmd
|| ! defined $category || ! defined $categoryPlural || ! defined $modelObj
) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->importInterface', @_);
}
# Extract profile (group 1) switch options
($profCount, $profCategory, $profName, @args) = $self->extractProfileSwitches(
$session,
$inputString,
$category,
'import',
@args,
);
if (! defined $profCount) {
# Error in ->extractProfileSwitches - error message already displayed
return undef;
}
# 0 or 1 associated profiles can be specified, but no more
if ($profCount > 1) {
lib/Games/Axmud/Generic.pm view on Meta::CPAN
}
# Check that the cage doesn't already have a trigger with the same name
if ($cage->ivExists('interfaceHash', $interfaceObj->name)) {
$failCount++;
next OUTER;
}
# Clone the interface
if ($interfaceObj->isa('Games::Axmud::Interface::Active')) {
$newObj = $interfaceObj->cloneToInactiveInterface($category);
} else {
$newObj = $interfaceObj->clone($profName);
}
if (! $newObj) {
$failCount++;
next OUTER;
}
# Tell the trigger cage that it has received a new trigger
$cage->ivAdd('interfaceHash', $newObj->name, $newObj);
# Get a list of profiles with higher priority than this one
@superiorList = $session->findSuperiorList($profCategory);
# Get a list of profiles with lower priority than this one
@inferiorList = $session->findInferiorList($profCategory);
# Check whether there are any triggers with the same name, belonging to a cage
# associated with a superior profile to this cage's profile. If none, create an
# interface for the trigger
# Also, if there is a trigger, with the same name but belonging to a cage associated
# with an inferior profile to this cage's profile, destroy its interface
# As a result, there should be exactly one interface for a trigger with this name, no
# matter how many triggers with that name exist
$result = $session->injectInterface(
$newObj,
$newObj->name,
$profName,
\@superiorList,
\@inferiorList,
);
if (! defined $result) {
$failCount++;
} else {
$successCount++;
}
}
return $self->complete(
$session, $standardCmd,
'Import complete, ' . $categoryPlural . ' imported: ' . $successCount . ', failures: '
. $failCount,
);
}
sub deleteInterface {
# Called by GA::Cmd::DeleteTrigger->do, DeleteAlias->do, DeleteMacro->do,
# DeleteTimer->do and DeleteHook->do
# (For the whole of this function, 'trigger' is taken to mean any of 'trigger', 'alias',
# 'macro', 'timer' or 'hook')
#
# This function deletes an independent trigger stored in a trigger cage. If there's a
# corresponding active interface, it is also deleted
#
# This function can also be called to delete an active interface directly, without
# deleting the corresponding independent trigger stored in a trigger cage (if any)
#
# Expected arguments
# $session - The calling function's GA::Session
# $inputString - The command actually typed, e.g. 'dtr mytrig'
# $standardCmd - Standard version of the client command, e.g. 'deletetrigger'
# $category - 'trigger', 'alias', 'macro', 'timer', 'hook'
# $categoryPlural - e.g. 'triggers'
# @args - The arguments specified by the user in the ';deletetrigger' command
#
# Return values
# 'undef' on improper arguments or if there's an error
# 1 on success
my (
$self, $session, $inputString, $standardCmd, $category, $categoryPlural,
@args,
) = @_;
# Local variables
my (
$profCount, $profCategory, $profName, $currentObj, $currentObjName, $cage, $result,
@inferiorList
);
# Check for improper arguments
if (
! defined $session || ! defined $inputString || ! defined $standardCmd
|| ! defined $category || ! defined $categoryPlural || ! @args
) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->deleteInterface', @_);
}
# Extract profile (group 1) switch option
($profCount, $profCategory, $profName, @args) = $self->extractProfileSwitches(
$session,
$inputString,
$category,
'delete',
@args,
);
if (! defined $profCount) {
# Error in ->extractProfileSwitches()
return undef;
# 0 or 1 associated profiles can be specified, but no more
} elsif ($profCount > 1) {
return $self->error(
$session, $inputString,
lib/Games/Axmud/Generic.pm view on Meta::CPAN
} else {
# Get the blessed reference of the trigger object (but don't consult inferior cages)
$currentObj = $cage->ivShow('interfaceHash', $currentObjName);
if (! $currentObj) {
return $self->error(
$session, $inputString,
'General error deleting the ' . $category . ' interface object \''
. $currentObjName . '\'',
);
}
}
# Delete the interface object
$cage->ivDelete('interfaceHash', $currentObjName);
# Get a list of profiles with lower priority than this one
@inferiorList = $session->findInferiorList($profCategory);
# If there's an active interface based on this trigger object, delete it also. At the
# same time, if there's a trigger with the same name, belonging to an inferior
# cage, create an interface for it to make it active
$result = $session->recallInterface($currentObj, $currentObjName, \@inferiorList);
if (! $result || $result == 1) {
return $self->error(
$session, $inputString,
'General error deleting ' . $category . ' interface',
);
} elsif ($result == 2) {
return $self->error(
$session, $inputString,
'Deleted ' . $category . ' interface, but couldn\'t create interface for a '
. $category . ' belonging to an inferior profile',
);
} elsif ($result == 3) {
return $self->complete(
$session, $standardCmd,
'Active ' . $category . ' interface \'' . $currentObjName . '\' deleted and'
. ' interface created for a ' . $category . ' belonging to an inferior profile',
);
} elsif ($result == 4) {
return $self->complete(
$session, $standardCmd,
'Active ' . $category . ' interface \'' . $currentObjName . '\' deleted (and'
. ' no other interface created to replace it)',
);
}
}
sub listInterface {
# Called by GA::Cmd::ListTrigger->do, ListAlias->do, ListMacro->do, ListTimer->do and
# ListHook->do
# (For the whole of this function, 'trigger' is taken to mean any of 'trigger', 'alias',
# 'macro', 'timer' or 'hook')
#
# Lists triggers stored in a trigger cage, or lists active triggers
#
# Expected arguments
# $session - The calling function's GA::Session
# $inputString - The command actually typed, e.g. 'ltr -w'
# $standardCmd - Standard version of the client command, e.g. 'listtrigger'
# $category - 'trigger', 'alias', 'macro', 'timer', 'hook'
# $categoryPlural - e.g. 'triggers'
#
# Optional arguments
# @args - The arguments specified by the user in the ';listtrigger' command
# (an empty list if none specified)
#
# Return values
# 'undef' on improper arguments or if there's an error
# 1 on success
my (
$self, $session, $inputString, $standardCmd, $category, $categoryPlural,
@args,
) = @_;
# Local variables
my (
$switch, $arg, $profObj, $owner, $cage, $string,
@list,
%hash, %modifiedHash,
);
# Check for improper arguments
if (
! defined $session || ! defined $inputString || ! defined $standardCmd
|| ! defined $category || ! defined $categoryPlural
) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->listInterface', @_);
}
# Extract the optional switch and argument
$switch = shift @args;
$arg = shift @args;
# There should be no arguments left
if (
@args
|| (
defined $switch && $switch ne '-w' && $switch ne '-g' && $switch ne '-r'
&& $switch ne '-c' && $switch ne '-x' && $switch ne '-d' && $switch ne '-i'
)
) {
return $self->improper($session, $inputString);
}
# ;ltr
# ;ltr -w , ;ltr -g , ;ltr -r , ;ltr -c
# ;ltr -x <category>
# ;ltr -d <profile>
# (etc)
lib/Games/Axmud/Generic.pm view on Meta::CPAN
return 1;
} else {
return undef;
}
}
sub aliasAttributesTab {
# AliasAttributes tab
#
# Expected arguments
# (none besides $self)
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $check) = @_;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->aliasAttributesTab', @_);
}
# Tab setup
my $grid = $self->addTab(
$self->notebook,
'_Attributes',
['Alias attributes'],
);
# Alias attributes
$self->addLabel($grid, '<b>Alias attributes</b>',
0, 12, 0, 1);
# Left column
$self->useCheckButton($grid, 'Ignore case', 'ignore_case', TRUE,
1, 6, 1, 2);
$self->useCheckButton($grid, 'Keep checking aliases after a match', 'keep_checking', TRUE,
1, 6, 2, 3);
# Right column
$self->useCheckButton($grid, 'Temporary alias', 'temporary', TRUE,
7, 12, 1, 2);
$self->addLabel($grid, 'Cooldown (in seconds)',
7, 9, 2, 3);
$self->useEntryWithIcon($grid, 'cooldown', 'float', 0, undef,
9, 12, 2, 3,
8, 8);
# Tab complete
return 1;
}
sub macroAttributesTab {
# MacroAttributes tab
#
# Expected arguments
# (none besides $self)
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $check) = @_;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->macroAttributesTab', @_);
}
# Tab setup
my $grid = $self->addTab(
$self->notebook,
'_Attributes',
['Macro attributes'],
);
# Macro attributes
$self->addLabel($grid, '<b>Macro attributes</b>',
0, 12, 0, 1);
# Left column
$self->useCheckButton($grid, 'Temporary macro', 'temporary', TRUE,
1, 6, 1, 2);
# Right column
$self->addLabel($grid, 'Cooldown (in seconds)',
7, 9, 1, 2);
$self->useEntryWithIcon($grid, 'cooldown', 'float', 0, undef,
9, 12, 1, 2,
8, 8);
# Tab complete
return 1;
}
sub timerAttributesTab {
# TimerAttributes tab
#
# Expected arguments
# (none besides $self)
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $check) = @_;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->timerAttributesTab', @_);
}
# Tab setup
my $grid = $self->addTab(
$self->notebook,
'_Timers',
['Timer attributes'],
);
# Timer attributes
$self->addLabel($grid, '<b>Timer attributes</b>',
0, 12, 0, 1);
# Left column
$self->addLabel($grid, 'Repeat count (-1 unlimited)',
1, 4, 1, 2);
$self->useEntryWithIcon($grid, 'count', 'int', -1, undef,
4, 6, 1, 2);
$self->addLabel($grid, 'Initial delay (0 for no delay)',
1, 4, 2, 3);
$self->useEntryWithIcon($grid, 'initial_delay', 'float', 0, undef,
4, 6, 2, 3);
$self->useCheckButton($grid, 'Random delays', 'random_delay', TRUE,
1, 6, 3, 4);
# Right column
lib/Games/Axmud/Generic.pm view on Meta::CPAN
foreach my $name (keys %$afterRemoveHashRef) {
if ($self->ivExists('afterHash', $name)) {
$self->ivDelete('afterHash', $name);
}
}
}
return 1;
}
##################
# Accessors - get
}
{ package Games::Axmud::Generic::InterfaceCage;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cage Games::Axmud);
##################
# Constructors
sub new {
# Inherited by GA::Cage::Trigger->new, etc
# Creates a new instance of a trigger, alias, macro, timer or hook cage
#
# Expected arguments
# $session - The calling function's GA::Session (not stored as an IV)
# $profName - The parent profile's name (e.g. matches the object's ->name)
# $profCategory - The profile's category (e.g. 'world', 'guild', 'faction' etc)
#
# Return values
# 'undef' on improper arguments or if the cage already seems to exist
# Blessed reference to the newly-created object on success
my ($class, $session, $profName, $profCategory, $check) = @_;
# Local variables
my (
$cageType, $name,
@typeList,
);
# Check for improper arguments
if (
! defined $session || ! defined $profName || ! defined $profCategory
|| defined $check
) {
return $axmud::CLIENT->writeImproper($class . '->new', @_);
}
# Is this a trigger, alias, macro, timer or hook cage?
@typeList = ('Trigger', 'Alias', 'Macro', 'Timer', 'Hook');
OUTER: foreach my $item (@typeList) {
if (index ($class, $item) > -1) {
$cageType = lc($item);
last OUTER;
}
}
# Compose the cage's unique name
$name = $cageType . '_' . $profCategory . '_' . $profName;
# Check that $name is valid and not already in use by another profile
if (! $axmud::CLIENT->nameCheck($name, 42)) {
return $session->writeError(
'Registry naming error: invalid name \'' . $name . '\'',
$class . '->new',
);
} elsif ($session->ivExists('cageHash', $name)) {
return $session->writeError(
'Registry naming error: cage \'' . $name . '\' already exists',
$class . '->new',
);
}
# Setup
my $self = {
_objName => $name,
_objClass => $class,
_parentFile => 'otherprof',
_parentWorld => $session->currentWorld->name,
_privFlag => FALSE, # All IVs are public
# Standard cage IVs
# -----------------
name => $name,
cageType => $cageType,
standardFlag => TRUE, # This is a built-in Axmud cage
profName => $profName,
profCategory => $profCategory,
# Interface cage IVs
# ------------------
# Hash of interfaces in the form
# $interfaceHash{interface_name} = blessed_reference_to_interface_object
interfaceHash => {},
};
# Bless the object into existence
bless $self, $class;
return $self;
}
sub clone {
( run in 1.030 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )