Games-Axmud
view release on metacpan or search on metacpan
lib/Games/Axmud/Session.pm view on Meta::CPAN
if (defined $activeObj->parent && $activeObj->parent eq $interfaceObj) {
$match = $activeObj;
last OUTER;
}
}
if (! $match) {
# No corresponding active interface to delete
return undef;
# Delete the active interface
} elsif (! $self->removeInterface($match)) {
# Return 1 to show a general error deleting the active interface
return 1;
}
# Other cages with a lower priority might already have an inactive interface with the same
# same name - if so, we must create a corresponding active interface
OUTER: foreach my $profCategory (@$inferiorListRef) {
my $cage = $self->findCurrentCage($interfaceObj->category, $profCategory);
if ($cage && $cage->ivExists('interfaceHash', $interfaceName)) {
# The TRUE flag means 'don't consult other cages'
$inactiveObj = $cage->ivShow('interfaceHash', $interfaceName, TRUE);
last OUTER;
}
}
if ($inactiveObj) {
# Create an active interface corresponding to the inferior cage's inactive interface
$newActiveObj = $self->createActiveInterface(
TRUE, # An independent active interface, not a dependent one
$inactiveObj, # Active interface based on the inactive interface $interfaceObj
);
if (! $newActiveObj) {
# Return 2 to show a general error creating a new active interface
return 2;
} else {
# Return 3 to show the deleted active interface has been replaced by a new one
# corresponding to an inactive interface from an inferior cage
return 3;
}
} else {
# Return 4 to show the active interface was deleted, and no other active interface
# was created
return 4;
}
}
sub updateInterfaces {
# Called by GA::Generic::Cmd->modifyInterface in response to ;modifytrigger, and so on
# When an inactive interface is modified, active interfaces in every session sharing the
# same current world might need to be updated. ->modifyInterface calls this function in
# every affected session
#
# Expected arguments
# $inactiveObj - The inactive interfaces which has been modified
# %attribHash - The hash of modified interface attributes created by the calling
# function (should not be empty)
#
# Return values
# 'undef' on improper arguments or if there's an error modifying an active interface
# 1 otherwise
my ($self, $inactiveObj, %attribHash) = @_;
# Check for improper arguments
if (! defined $inactiveObj || ! %attribHash) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateInterfaces', @_);
}
foreach my $activeObj ($self->ivValues('interfaceHash')) {
my $timerEnableFlag;
if (defined $activeObj->parent && $activeObj->parent eq $inactiveObj) {
# For active timer interfaces that are disabled, but are about to become
# enabled, some additional IVs need to be set
if (
$activeObj->category eq 'timer' # It's a timer
&& ! $activeObj->enabledFlag # Currently disabled
&& exists ($attribHash{'enabled'}) # The 'enabled' attribute will be set
) {
$timerEnableFlag = TRUE;
}
# Modify the interface
if (! $activeObj->modifyAttribs($self, %attribHash)) {
return undef;
} else {
if ($timerEnableFlag && $activeObj->enabledFlag) {
# A disabled timer has become enabled. Set a few IVs
$activeObj->becomeEnabled();
}
return 1;
}
}
}
}
sub deleteInterface {
lib/Games/Axmud/Session.pm view on Meta::CPAN
my ($profName, $profCategory);
# Check for improper arguments
if (! defined $profObj || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->createCages', @_);
}
# Import IVs
$profName = $profObj->name;
$profCategory = $profObj->category;
# Create one new cage for each cage type
foreach my $type ($axmud::CLIENT->cageTypeList) {
my ($package, $obj);
if ($axmud::CLIENT->ivExists('pluginCagePackageHash', $type)) {
# Cage added by a plugin
$package = $axmud::CLIENT->ivShow('pluginCagePackageHash', $type);
} else {
# Built-in cage
$package = 'Games::Axmud::Cage::' . ucfirst($type);
}
$obj = $package->new($self, $profName, $profCategory);
if (! $obj) {
$self->writeWarning(
'Failed to create the \'' . $package . '\' cage for the \'' . $profName
. '\' profile',
$self->_objClass . '->createCages',
);
} else {
# Use the 'set' accessor rather than ->ivAdd so that other sessions using the same
# world profile are updated, too
$self->add_cage($obj);
}
}
# If this is a current profile, and there were no errors, mark the new objects as current
# cages and set the inferior cage for all cages (those not belonging to a current profile
# have their inferior cage set to 'undef')
if ($currentFlag) {
$self->setCurrentCages($profName, $profCategory);
$self->setCageInferiors();
# Create new interfaces for this profile
$self->setProfileInterfaces($profObj->name)
}
return 1;
}
sub updateCages {
# Called by $self->setupProfiles, GA::Client->addPluginCages are by code in any plugin
# If the user writes a plugin which adds new cages, existing profiles each need to have one
# of these cages created for it
#
# Expected arguments
# (none besides $self)
#
# Optional arguments
# $silenceFlag - If set to TRUE, doesn't display a message for each cage created
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $silenceFlag, $check) = @_;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateCages', @_);
}
foreach my $profObj ($self->ivValues('profHash')) {
# Check every type of cage. If a cage associated with the profile doesn't exist, create
# it
foreach my $type ($axmud::CLIENT->cageTypeList) {
my ($uniqueName, $package, $obj);
$uniqueName = lc($type) . '_' . $profObj->category . '_' . $profObj->name;
if (! $self->ivExists('cageHash', $uniqueName)) {
# Cage doesn't already exist, so create it
if ($axmud::CLIENT->ivExists('pluginCagePackageHash', $type)) {
# Cage added by a plugin
$package = $axmud::CLIENT->ivShow('pluginCagePackageHash', $type);
} else {
# Built-in cage
$package = 'Games::Axmud::Cage::' . ucfirst($type);
}
$obj = $package->new($self, $profObj->name, $profObj->category);
if (! $obj) {
# Show a warning message, even if $silenceFlag is TRUE
$self->writeWarning(
'Failed to create the \'' . $package . '\' cage for the \''
. $profObj->name . '\' profile',
$self->_objClass . '->updateCages',
);
} else {
# Add the new cage to this session's registries
lib/Games/Axmud/Session.pm view on Meta::CPAN
# End of the element found
return substr($origText, 0, $elemLength);
}
}
sub extractMxpPuebloEntity {
# Called by $self->processIncomingData when it encounters a "&" character, which probably
# starts an MXP/Pueblo entity
# Attempts to extract a valid MXP/Pueblo entity in the form &keyword;
# The entity keyword must start with a letter (A-Za-z) and then consist of letters, numbers
# or underline characters. No other characters are permitted (including non-Latin
# alphabets)
# (This function also recognises entities in the form '&#nnn;' )
# If a valid entity isn't found, the calling function displays the text 'as is'
#
# NB The calling function should have checked that MXP or Pueblo is enabled, i.e.
# $self->mxpMode or $self->puebloMode is 'client_agree'
#
# Expected arguments
# $text - The remaining portion of the received text, which in this case starts with a
# "&" character
#
# Return values
# 'undef' on improper arguments or if an invalid entity is found
# Otherwise returns the token containing the valid entity
my ($self, $text, $check) = @_;
# Check for improper arguments
if (! defined $text || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->extractMxpPuebloEntity', @_);
}
# Check there is some text after the initial "&" character
if (length $text <= 1) {
return undef;
}
# Try to extract an entity
if ($text =~ m/(\&[A-Za-z][A-Za-z0-9_]*\;)/) {
return $1;
# Entities in the form '&#nnn;' are also recognised
} elsif ($text =~ m/(\&\#[0-9]{1,3}\;)/) {
return $1;
} else {
return undef;
}
}
# (Called by ->processIncomingData to convert a non-text token into a tag list)
sub updateEndLine {
# Called by $self->processIncomingData
#
# After a line portion ending in a newline character has been displayed, updates IVs and
# prepares a list of Axmud colour/style tags that should be applied to the beginning of
# the next line (because of MXP stuff)
#
# Expected arguments
# $type - The token type, 'nl' for an ordinary newline token or 'go' for an
# artificially-inserted newline token
#
# Return values
# An empty list on improper arguments
# Otherwise returns a list of Axmud colour/style tags that should be applied to the
# beginning of the next line (may be an empty list)
my ($self, $type, $check) = @_;
# Local variables
my (@emptyList, @tagList);
# Check for improper arguments
if (! defined $type || defined $check) {
$axmud::CLIENT->writeImproper($self->_objClass . '->updateEndLine', @_);
return @emptyList;
}
if (defined $self->mxpLineMode) {
# If we're in the middle of a <V>...</V> construction, the construction is abnormally
# terminated
if ($self->mxpCurrentVar) {
$self->mxpDebug(
"\n",
'Variable abnormally terminated by newline character',
1301,
);
$self->ivUndef('mxpCurrentVar');
}
# If we're in the middle of an <A>...</A> construction, the construction is abnormally
# terminated
if ($self->mxpCurrentLink) {
$self->mxpDebug(
"\n",
'Link abnormally terminated by newline character',
1302,
);
$self->ivUndef('mxpCurrentLink');
}
# If we're in the middle of a <SEND>...</SEND> construction, the construction is
# abnormally terminated
if ($self->mxpCurrentSend) {
lib/Games/Axmud/Session.pm view on Meta::CPAN
my ($self, $token, $text, $check) = @_;
# Local variables
my ($enNum, $enName, $entityObj);
# Check for improper arguments
if (! defined $token || ! defined $text || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->processMxpEntity', @_);
}
# Handle entities in the form '&#nnn;'
if ($token =~ m/\&\#([0-9]{1,3})\;/) {
$enNum = $1;
# We'll assume that 'nnn' can be '064' as well as '64'. Convert it to a numeric value
$enNum += 0;
# Ignore numbers not in the range 32-255
if ($enNum < 32 || $enNum > 255) {
return undef;
} else {
return chr($enNum);
}
}
# Otherwise, get the entity name (the token will have at least three characters, due to the
# regex used in $self->extractMxpPuebloEntity, so there's no need to check for a minimum
# length)
$enName = substr($token, 1, (length($token) - 2));
# Does an entity called $enName exist?
if (! $self->ivExists('mxpEntityHash', $enName)) {
# Standard entity names don't have their own GA::Mxp::Entity object
if (! $axmud::CLIENT->ivExists('constMxpEntityHash', $enName)) {
$self->mxpDebug($token, 'Unrecognised entity \'' . $enName . '\'', 3901);
return undef;
} else {
# Use the standard entity's value (an ASCII character)
return $axmud::CLIENT->ivShow('constMxpEntityHash', $enName);
}
} else {
# Replace the named entity with its value
$entityObj = $self->ivShow('mxpEntityHash', $enName);
return $entityObj->value;
}
}
# (Called by ->processIncomingData to handle a text token)
sub updateTextToken {
# Called by $self->processIncomingData
# Also called by $self->processMxpSpacingTag when processing a <SBR> or <HR> tag
#
# Updates IVs after a text token (a string which doesn't contain any of the none-text tokens
# removed by the calling function, such as newline characters, escape sequences, etc) is
# processed
#
# Expected arguments
# $token - The token containing the text
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $token, $check) = @_;
# Check for improper arguments
if (! defined $token || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateTextToken', @_);
}
# If we're in the middle of a <V>...</V> construction, update the variable's value
if ($self->mxpCurrentVar) {
$self->mxpCurrentVar->ivPoke('value', $self->mxpCurrentVar->value . $token);
}
# If we're in the middle of an <A>...</A> construction, update the link's visible text
if ($self->mxpCurrentLink) {
$self->mxpCurrentLink->ivPoke('text', $self->mxpCurrentLink->text . $token);
}
# If we're in the middle of a <SEND>...</SEND> construction, update the link's visible text
if ($self->mxpCurrentSend) {
$self->mxpCurrentSend->ivPoke('text', $self->mxpCurrentSend->text . $token);
}
# If we're in the middle of two matching custom tags which defined tag properties, e.g.
# from the MXP spec, <RName>...</RName>, update the stored text
foreach my $key ($self->ivKeys('mxpFlagTextHash')) {
$self->ivAdd('mxpFlagTextHash', $key, $self->ivShow('mxpFlagTextHash', $key) . $token);
}
return 1;
}
# (Miscellaneous incoming functions)
sub writeIncomingDataLogs {
# Called by $self->processLineSegment to write logs after each line segment (usually
# comprising a whole line) is received from the world, and after any matching triggers
# have fired)
# NB $self->writeReceiveDataLog is used to write the 'receive' logfile; this function is
# used to write all other logfiles
lib/Games/Axmud/Session.pm view on Meta::CPAN
}
if ($value =~ m/(\d+)([\%c]?)/) {
$num = $1;
$type = $2;
if (! $type) {
# $value was already in pixels
return int($value);
} elsif ($type eq 'c') {
# Get size of an X character
($charWidth, $charHeight) = $self->currentTabObj->textViewObj->getCharSize('X');
if ($mode eq 'width') {
return int($num * $charWidth);
} elsif ($mode eq 'height') {
return int($num * $charHeight);
} else {
# Emergency default
return undef;
}
} else {
# Get the size of the default tab's textview, in pixels
# Convert the percentage into a fraction (e.g. convert 50% into 0.5)
$num /= 100;
# Get a Gtk3::Gdk::Rectangle
$rectObj = $self->defaultTabObj->textViewObj->textView->get_visible_rect();
if ($mode eq 'width') {
return int($num * $rectObj->width);
} elsif ($mode eq 'height') {
return int($num * $rectObj->height);
} else {
# Emergency default
return undef;
}
}
} else {
# Invalid image size format (not 'n', 'nc' or 'n%'
return undef;
}
}
sub updateMxpGauges {
# Called by $self->spinMaintainLoop
# When an MXP entity is modified (including being created or deleted), an entry is added
# to $self->mxpGaugeUpdateHash
# Once per maintenance loop, this function is called. The function checks whether any of the
# modified entities have corresponding 'main' window gauges and, if so, updates the
# GA::Obj::Gauge objects and redraws the gauges
# This function also checks the world profile's ->mxpStatusVarHash. If a modified MXP
# entity has an equivalent Status task variable, it is passed on to the Status task
#
# Expected arguments
# (none besides $self)
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $check) = @_;
# Local variables
my (
$updateFlag,
@deleteList,
);
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateMxpGauges', @_);
}
foreach my $entName ($self->ivKeys('mxpGaugeUpdateHash')) {
my ($entityObj, $gaugeObj, $taskVar);
# If the entity has been deleted, its gauge must be removed
if (! $self->ivExists('mxpEntityHash', $entName)) {
push (@deleteList, $entName);
} else {
# Update the corresponding gauge object, if it has actually been created
$gaugeObj = $self->ivShow('mxpGaugeHash', $entName);
if ($gaugeObj) {
$updateFlag = TRUE;
$entityObj = $self->ivShow('mxpEntityHash', $entName);
if (defined $entityObj) {
if ($gaugeObj->mxpEntity eq $entName) {
$gaugeObj->ivPoke('value', $entityObj->value);
} else {
$gaugeObj->ivPoke('maxValue', $entityObj->value);
}
}
}
# Pass the value on to the Status task, if possible
lib/Games/Axmud/Session.pm view on Meta::CPAN
$telConstHash{'TELNET_SB'},
$telConstHash{'TELOPT_GMCP'},
$payload,
$telConstHash{'TELNET_IAC'},
$telConstHash{'TELNET_SE'},
);
if (
! $self->connectObj->put(
String => $telCmd,
Telnetmode => 0,
)
) {
return undef;
} else {
return 1;
}
}
# Telnet option negotiation / MUD protocols - support functions
sub checkOptList {
# Called by various functions
# Telnet option negotation requires that the value 255 should represent TELNET_IAC; if the
# actual value 255 is needed, it must be double-escaped
# Check a list of one or more values in the range 0-255 and deal with any 255 values
# (e.g. convert the list (100, 200, 255, 0) into (100, 200, 255, 255, 0)
#
# Expected arguments
# (none besides $self)
#
# Optional arguments
# @list - A list of values in the range 0-255 (can be an empty list)
#
# Return values
# An empty list on improper arguments
# Otherwise returns the modified list
my ($self, @list) = @_;
# Local variables
my @modList;
# (No improper arguments to check)
foreach my $value (@list) {
push (@modList, $value);
if ($value == 255) {
# Double escape this value
push (@modList, $value);
}
}
return @modList;
}
sub updateEcho {
# Called by $self->optCallback when the server requests that the client stop/resume ECHOing
# (also called by $self->disableTelnetOption)
# If this is the current session and the client is not ECHOing world commands, obscures text
# in the command entry box for any 'internal' windows used by this session
#
# Expected arguments
# (none besides $self)
#
# Optional arguments
# $unobscureFlag - Set to TRUE when called by $self->doLogin, in which case we unobscure
# the command entry box, regardless of the setting of $self->echoMode
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $unobscureFlag, $check) = @_;
# Local variables
my @list;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateEcho', @_);
}
# Generate a list of this session's entry strip objects (the TRUE argument means 'only
# return 'internal' windows')
foreach my $winObj ($axmud::CLIENT->desktopObj->listSessionGridWins($self, TRUE)) {
my $stripObj = $winObj->ivShow('firstStripHash', 'Games::Axmud::Strip::Entry');
if (
$stripObj
&& $stripObj->winObj->visibleSession
&& $stripObj->winObj->visibleSession eq $self
) {
push (@list, $stripObj);
}
}
foreach my $stripObj (@list) {
# (The server has suggested that the client stop ECHOing, and the client has agreed)
if ($self->echoMode eq 'client_agree' && ! $unobscureFlag) {
$stripObj->obscureEntry(TRUE);
# (The server has suggested that the client stop ECHOing, and the client has refused)
# (The server has suggested that the client resume ECHOing, and the client has agreed)
} else {
$stripObj->obscureEntry(FALSE);
}
}
# If the ECHO telnet option has been turned off and this session's special echo mode is
# enabled, disable it (extremely unlikely, but we'll check anyway)
if ($self->echoMode ne 'client_agree' && $self->specialEchoMode eq 'enabled') {
$self->ivPoke('specialEchoMode', 'disabled');
# Need to inform the strip objects. Can't incorporate this code into the foreach loop
# just above, because $unobscureFlag is a complicating factor
# (If the ECHO telnet option is turned back on at some later point, don't re-enable
# special echo mode. It's only enabled shortly after a login is completed)
foreach my $stripObj (@list) {
$stripObj->set_specialEchoFlag(FALSE);
}
}
return 1;
}
sub updateSpecialEcho {
# Called by $self->processIncomingData whenever there's a change in this session's special
# echo mode, in which case all strip entry objects (GA::Strip::Entry) must be informed
#
# 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 . '->updateSpecialEcho', @_);
}
# (The TRUE argument means 'only return 'internal' windows)
foreach my $winObj ($axmud::CLIENT->desktopObj->listSessionGridWins($self, TRUE)) {
my $stripObj = $winObj->ivShow('firstStripHash', 'Games::Axmud::Strip::Entry');
if ($stripObj) {
# Make sure the entry box is unobscured (assuming this session is the visible one,
# and that the world has actually turned on echo mode)
# visible one)
if (
$stripObj->winObj->visibleSession
&& $stripObj->winObj->visibleSession eq $self
&& $self->echoMode eq 'client_agree'
) {
$stripObj->obscureEntry(FALSE);
}
if ($self->specialEchoMode eq 'enabled') {
# Tell the strip entry object to start sending characters to the world, one at a
# time, as soon as they're typed (but only for world commands)
$stripObj->set_specialEchoFlag(TRUE);
} else {
# Tell the strip entry object to stop doing that
$stripObj->set_specialEchoFlag(FALSE);
}
}
}
return 1;
}
sub prepareTTypeData {
# Called by $self->optCallback when the server first requests TTYPE data
# Prepares (or resets) the items to be during TTYPE option sub-negotiations
#
# Expected arguments
# (none besides $self)
lib/Games/Axmud/Session.pm view on Meta::CPAN
}
# Check every line in the instruction buffer, looking for an instruction which starts with
# $currentText, and continues with one or more extra characters
if (%bufferHash) {
for (my $num = $last; $num >= $first; $num--) {
my ($bufferObj, $string, $diff);
$bufferObj = $bufferHash{$num};
if ($bufferObj) {
$string = $bufferObj->$iv;
$diff = length($string) - length($currentText);
if (
(
$diff > 0
&& $string ne $currentText
&& substr($string, 0, length($originalText)) eq $originalText
) || (
$diff == 0
&& $string ne $currentText
&& $string gt $currentText
)
) {
# Potential match found. Use it if...
if (
# It's the first match found
! defined $matchString
# It is shorter than the previous matched string
|| length($string) < length($matchString)
# In alphabetical order, it appears earlier than the matched string
|| (
length($string) == length($matchString)
&& $string lt $matchString
)
) {
$matchString = $string;
$matchNum = $num;
}
}
}
}
}
if (! defined $matchString) {
# No matches found; use an empty string in the command entry box
return undef;
} else {
return $bufferHash{$matchNum};
}
}
# Buffers
sub updateDisplayBuffer {
# Called by $self->processLineSegment when a complete line of text has been received from
# the world and displayed in a textview
# Updates the display buffer
#
# Expected arguments
# $line - The original line of text received from the world
# $stripLine - $line after being stripped of escape sequences
# $modLine - $stripLine after being modified by any matching interfaces (identical
# to $stripLine if none match)
# $newLineFlag - TRUE if $line ends with a newline character, FALSE if it doesn't
# $offsetListRef - Reference to a sorted list containing the offsets (positions in
# $modLine) at which escape sequences occured, before they were
# stripped away
# $offsetHashRef - Reference to a hash in the form
# $tagHash{offset} = reference_to_list_of_colour_and_style_tags
# - Each offset represents the position of a character in $modLine
# - Axmud colour and style tags each correspond to an escape sequence
# $appliedListRef - Reference to a list of Axmud colour/style tags that actually applied
# at the beginning of the line (may be an empty list)
# $mxpFlagTextHashRef
# - Reference to the contents of $self->mxpFlagTextStoreHash, just before
# it was reset (may be an empty hash)
#
# Return values
# 'undef' on improper arguments, if the session is not connected to a world or if the
# buffer can't be updated
# Otherwise returns the new buffer object created (or the existing buffer object
# modified)
my (
$self, $line, $stripLine, $modLine, $newLineFlag, $offsetListRef, $offsetHashRef,
$appliedListRef, $mxpFlagTextHashRef, $check,
) = @_;
# Local variables
my (
$lastObj, $thisObj,
%tagHash,
);
# Check for improper arguments
if (
! defined $line || ! defined $stripLine || ! defined $modLine || ! defined $newLineFlag
|| ! defined $offsetListRef || ! defined $offsetHashRef || ! defined $appliedListRef
|| defined $check
) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateDisplayBuffer', @_);
}
# Don't update the buffer after a disconnection (but do update it in 'connect offline'
# mode); in addition, only text displayed in the default tab is added to the display
# buffer
if ($self->status eq 'disconnected' || $self->currentTabObj ne $self->defaultTabObj) {
return undef;
}
if (! defined $self->displayBufferFirst) {
lib/Games/Axmud/Session.pm view on Meta::CPAN
$modLine,
$self->sessionTime,
$newLineFlag,
$offsetHashRef,
\%tagHash,
$appliedListRef,
$mxpFlagTextHashRef,
);
if (! $thisObj) {
return undef;
} else {
# Update the display buffer
$self->ivAdd('displayBufferHash', $thisObj->number, $thisObj);
$self->ivIncrement('displayBufferCount');
$self->ivPoke('displayBufferLast', ($self->displayBufferCount - 1));
# If the buffer is full, remove the oldest line
if ($self->displayBufferCount > $axmud::CLIENT->customDisplayBufferSize) {
$self->ivDelete('displayBufferHash', $self->displayBufferFirst);
$self->ivIncrement('displayBufferFirst');
}
}
} else {
# Previous line didn't end with a newline character. Append the new text to the
# previous line
$lastObj->update(
$line,
$stripLine,
$modLine,
$newLineFlag,
$offsetHashRef,
\%tagHash,
$mxpFlagTextHashRef,
);
}
# Set the time at which text was most recently received from the world and displayed in the
# default tab
if ($self->defaultTabObj eq $self->currentTabObj) {
$self->ivPoke('lastDisplayTime', $self->sessionTime);
}
# Allow the 'world_idle' hook event to happen ($self->constHookIdleTime seconds from now)
$self->ivPoke('disableWorldIdleFlag', FALSE);
if ($thisObj) {
return $thisObj;
} else {
return $lastObj;
}
}
sub updateInstructBuffer {
# Called by $self->doInstruct after the user types an instruction in a 'main' window (when
# this is the window's visible session), or when any other part of the code calls
# $self->doInstruct
# Also called directly by a ->signal_connect in GA::Strip::Entry->setEntrySignals, when in
# special echo mode (as that function doesn't call $self->doInstruct)
#
# Updates the instruction buffer
#
# Expected arguments
# $instruct - The instruction itself (e.g. ';setworld deathmud' or 'north;kill orc')
# $type - The type of instruction: 'client' for a client command, 'world' for a
# world command, 'perl' for a Perl command and 'echo' for an echo command
#
# Return values
# 'undef' on improper arguments, if the session is not connected to a world or if the
# buffer is not updated
# Otherwise returns the buffer object created
my ($self, $instruct, $type, $check) = @_;
# Local variables
my $obj;
# Check for improper arguments
if (! defined $instruct || ! defined $type || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateInstructBuffer', @_);
}
# Don't update the buffer after a disconnection (but do update it in 'connect offline' mode)
if ($self->status eq 'disconnected') {
return undef;
}
if (! defined $self->instructBufferFirst) {
# This the first instruction ever processed
$self->ivPoke('instructBufferFirst', 0);
}
# Create a new buffer object for this instruction
$obj = Games::Axmud::Buffer::Instruct->new(
$self,
'session',
$self->instructBufferCount,
$instruct,
$type,
$self->sessionTime,
);
if (! $obj) {
return undef;
} else {
# Update the instruction buffer
$self->ivAdd('instructBufferHash', $obj->number, $obj);
$self->ivIncrement('instructBufferCount');
$self->ivPoke('instructBufferLast', ($self->instructBufferCount - 1));
# If the buffer is full, remove the oldest line
if ($self->instructBufferCount > $axmud::CLIENT->customInstructBufferSize) {
$self->ivDelete('instructBufferHash', $self->instructBufferFirst);
$self->ivIncrement('instructBufferFirst');
}
# Also add a separate buffer object (with a different ->number) to the equivalent
# registry in the GA::Client
$axmud::CLIENT->updateInstructBuffer($self, $instruct, $type);
}
# Set the time at which the last instruction was executed
$self->ivPoke('lastInstructTime', $self->sessionTime);
return $obj;
}
sub updateCmdBuffer {
# Called by $self->dispatchCmd, ->teleportCmd, and also by ->checkRedirect and
# ->checkAssistedMove
# Also called by $self->teleportCmd, after an earlier call by GA::Cmd::Teleport->do
#
# Updates the world command buffer
#
# Expected arguments
# $cmd - The world command itself (e.g. 'north', 'kill orc')
#
# Optional arguments
# $cage - The highest-priority command cage (quite unlikely that this is set to
# 'undef')
# $redirectCmd - For redirect mode commands, the substitute command (e.g. if $cmd is
# 'north', $redirectCmd might be 'sail north')
# $standardCmd - For assisted moves, the standard primary direction equivalent to the
# custom primary direction stored in $cmd. Set to 'undef' for
# everything else
# $assistedCmd - For assisted moves, the sequence of world commands corresponding to
# the standard primary direction, $cmd (e.g. 'open door;north'). Set
# to 'undef' for everything else
# $exitObj - For assisted moves, the GA::Obj::Exit used for the movement (an exit
# somewhere in the exit model). Set to 'undef' for everything else
# $teleportFlag - When called by $self->teleportCmd, flag set to TRUE ('undef'
# otherwise)
# $destRoom - When called by $self->teleportCmd, the world model number of the
# destination room (if known; 'undef' if not, or if not called by
# $self->teleportCmd)
#
# Return values
# 'undef' on improper arguments, if the session is not connected to a world or if the
# buffer can't be updated
# Otherwise returns the buffer object created
my (
$self, $cmd, $cage, $redirectCmd, $standardCmd, $assistedCmd, $exitObj,
$teleportFlag, $destRoom, $check
) = @_;
# Local variables
my ($obj, $newGhost, $dir, $unabbrevDir, $exitNum);
# Check for improper arguments
if (! defined $cmd || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateCmdBuffer', @_);
}
# Don't update the buffer after a disconnection (but do update it in 'connect offline' mode)
if ($self->status eq 'disconnected') {
return undef;
}
if (! defined $self->cmdBufferFirst) {
# This the first world command ever sent
$self->ivPoke('cmdBufferFirst', 0);
}
lib/Games/Axmud/Session.pm view on Meta::CPAN
$dir = $obj->cmd;
# For everything else, the direction of movement is stored in ->moveDir
} else {
$dir = $obj->moveDir;
}
# Improve our chances of finding a match by un-abbreviating $dir (if it's a
# primary direction)
$unabbrevDir = $self->currentDict->unabbrevDir($dir);
if ($unabbrevDir) {
$dir = $unabbrevDir;
}
# Does the ghost room have an exit in this direction?
if ($self->mapObj->ghostRoom->ivExists('exitNumHash', $dir)) {
$exitNum = $self->mapObj->ghostRoom->ivShow('exitNumHash', $dir);
$exitObj = $self->worldModelObj->ivShow('exitModelHash', $exitNum);
# The new ghost room is the exit's destination room (may be set to 'undef')
$newGhost = $exitObj->destRoom;
}
}
if ($newGhost) {
# Set the automapper's ghost room
$self->mapObj->setGhostRoom($self->worldModelObj->ivShow('modelHash', $newGhost));
# # v1.0.284 - resetting the ghost room here leaves Cryosphere (and other similar worlds)
# # unable to accept commands like 'w' and 'east' as alternatives for 'port' and
# # 'starboard' - for now, we'll leave the ghost room unaltered, and let GA::Obj::Map
# # make any necessary changes
# } else {
#
# # Reset the automapper's ghost room
# $self->mapObj->setGhostRoom();
}
}
# If the Locator task is running (i.e. not paused), inform it that a new GA::Buffer::Cmd
# object has been added to the command buffer
if (
$self->locatorTask
&& $self->locatorTask->status eq 'running'
&& $self->status ne 'offline'
) {
$self->locatorTask->add_cmdObj($obj);
}
# Set the time at which the most recent world command was sent
$self->ivPoke('lastCmdTime', $self->sessionTime);
# Allow the 'user_idle' hook event to happen ($self->constHookIdleTime seconds from now)
$self->ivPoke('disableUserIdleFlag', FALSE);
return $obj;
}
sub updateBufferSize {
# Called by GA::Cmd::SetDisplayBuffer->do, GA::Cmd::SetInstructionBuffer->do and
# GA::Cmd::SetCommandBuffer->do
# When a default buffer size is changed (i.e. when GA::Client->customDisplayBufferSize,
# etc, are modified), checks whether this session's buffer IVs must be updated
# (Specifically, if the buffer has been made smaller, then buffer lines must be deleted)
#
# Expected arguments
# $type - 'display', 'instruct' or 'cmd'
# $size - The new default buffer size, matching
# GA::Client->customDisplayBufferSize, etc
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $type, $size, $check) = @_;
# Local variables
my $newFirst;
# Check for improper arguments
if (! defined $type || ! defined $size || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->updateCmdBuffer', @_);
}
# Don't update buffers after a disconnection (but do update them in 'connect offline' mode)
if ($self->status eq 'disconnected') {
return undef;
}
if ($type eq 'display') {
if (
$self->displayBufferCount
&& ($self->displayBufferLast - $self->displayBufferFirst + 1) > $size
) {
$newFirst = $self->displayBufferLast - $size + 1;
for (my $count = $self->displayBufferFirst; $count < $newFirst; $count++) {
$self->ivDelete('displayBufferHash', $count);
}
$self->ivPoke('displayBufferFirst', $newFirst);
}
} elsif ($type eq 'instruct') {
if (
$self->instructBufferCount
&& ($self->instructBufferLast - $self->instructBufferFirst + 1) > $size
) {
$newFirst = $self->instructBufferLast - $size + 1;
for (my $count = $self->instructBufferFirst; $count < $newFirst; $count++) {
$self->ivDelete('instructBufferHash', $count);
}
$self->ivPoke('instructBufferFirst', $newFirst);
}
} elsif ($type eq 'cmd') {
if (
$self->cmdBufferCount
&& ($self->cmdBufferLast - $self->cmdBufferFirst + 1) > $size
) {
$newFirst = $self->cmdBufferLast - $size + 1;
for (my $count = $self->cmdBufferFirst; $count < $newFirst; $count++) {
$self->ivDelete('cmdBufferHash', $count);
}
$self->ivPoke('cmdBufferFirst', $newFirst);
}
}
return 1;
}
# Blinkers
sub updateBlinkers {
# Called by GA::Client->spinClientLoop
# Updates blinker states for this session
#
# Expected arguments
# (none besides $self)
#
# Return values
# 'undef' on improper arguments
# 1 otherwise
my ($self, $check) = @_;
# Local variables
my %hash;
# Check for improper arguments
if (defined $check) {
return $self->writeImproper($self->_objClass . '->updateBlinkers', @_);
}
# Import the blinker state hash (for convenience)
%hash = $self->blinkerStateHash;
foreach my $blinkerNum (keys %hash) {
my $blinkerState = $hash{$blinkerNum};
# Update the blinker's state; the calling function will actually make the call
# GA::Strip::ConnectInfo->drawBlinker for every blinker that needs to be redrawn
if (defined $blinkerState) {
if ($blinkerState < $axmud::CLIENT->clientTime) {
# Turn the blinker off
$hash{$blinkerNum} = undef;
}
}
}
# Update IVs
$self->ivPoke('blinkerStateHash', %hash);
return 1;
}
sub turnOnBlinker {
# Called by $self->processIncomingData, ->dispatchCmd, ->dispatchPassword,
# ->processEscSequence, ->optCallback and ->subOptCallback
# Marks one (or all) of the blinkers to be turned on by changing their state
# (GA::Client->spinClientLoop actually draws a new blinker, as required)
# Does nothing when $self->status is 'offline' or 'disconnected'
#
# Expected arguments
# $choice - Which blinker to turn on. -1 to turn on all blinkers, or one of the keys
# in $self->blinkerStateHash (matching GA::Obj::Blinker->number)
#
# Return values
lib/Games/Axmud/Session.pm view on Meta::CPAN
return $axmud::CLIENT->writeImproper($self->_objClass . '->set_spelunkerMode', @_);
}
# Update IVs
$self->ivPoke('spelunkerMode', $mode);
return 1;
}
sub add_standardTask {
my ($self, $obj, $check) = @_;
# Check for improper arguments
if (! defined $obj || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->add_standardTask', @_);
}
# Update IVs. If the task is one of Axmud's built-in tasks, e.g. the TaskList task, this
# object will have its ->shortCutIV set
if ($obj->shortCutIV && $self->ivMember($obj->shortCutIV)) {
# This built-in task has started running
$self->ivPoke($obj->shortCutIV, $obj);
return 1;
} else {
# Not a built-in task
return undef;
}
}
sub del_standardTask {
my ($self, $obj, $check) = @_;
# Check for improper arguments
if (! defined $obj || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->del_standardTask', @_);
}
# Update IVs. If the task is one of Axmud's built-in tasks, e.g. the TaskList task, this
# object will have its ->shortCutIV set
# NB When a task shuts down, other IVs are set by $self->taskLoop
if ($obj->shortCutIV && $self->ivMember($obj->shortCutIV)) {
# This built-in task is no longer running
$self->ivUndef($obj->shortCutIV);
return 1;
} else {
# Not a built-in task
return undef;
}
}
sub update_statusTask {
my ($self, $check) = @_;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->update_statusTask', @_);
}
# Update the status task, if it's running
if ($self->statusTask) {
$self->statusTask->set_updateFlag(TRUE);
}
return 1;
}
sub add_systemMsg {
my ($self, $type, $msg, $check) = @_;
# Check for improper arguments
if (! defined $type || ! defined $msg || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->add_systemMsg', @_);
}
# If the Session Console window is actually open, display it there immediately
if ($self->consoleWin) {
$self->consoleWin->update($type, $msg);
} else {
$self->ivPush('systemMsgList', $type, $msg);
if ($type eq 'error' || $type eq 'warning' || $type eq 'improper') {
$self->ivPoke('systemMsgMode', 'error');
} elsif ($type eq 'debug' && $self->systemMsgMode ne 'error') {
$self->ivPoke('systemMsgMode', 'debug');
} elsif (
$type eq 'system'
&& $self->systemMsgMode ne 'error'
&& $self->systemMsgMode ne 'debug'
) {
$self->ivPoke('systemMsgMode', 'system');
}
# (The colour of the button, while flashing, might be different to the colour when it
# stops flashing)
if ($type eq 'error' || $type eq 'warning' || $type eq 'improper') {
$self->ivPoke('systemMsgTempMode', 'error');
} else {
$self->ivPoke('systemMsgTempMode', $type);
}
( run in 0.693 second using v1.01-cache-2.11-cpan-39bf76dae61 )