Games-Axmud
view release on metacpan or search on metacpan
lib/Games/Axmud/Session.pm view on Meta::CPAN
if ($stripObj) {
$stripObj->removeSessionGauges($self, TRUE);
}
}
}
# Make sure all changes are visible immediately
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->reactDisconnect');
# Update gauge IVs stored by MXP
$self->ivUndef('mxpGaugeLevel');
$self->ivEmpty('mxpGaugeHash');
return 1;
}
sub connectionError {
# Callback, called by $self->doConnect when the GA::Obj::Telnet object reports an error
# (usually due to a disconnection)
#
# Expected arguments
# $errorMsg - The error message passed by GA::Obj::Telnet
#
# Return values
# 'undef'
my ($self, $errorMsg, $check) = @_;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->connectionError', @_);
}
# NB If attempting a connection to a host, where both the host address and host port are
# invalid (c.f. 'telnet deathmud'), this function is called twice. If we are already
# disconnected, don't display a second error
if ($self->status eq 'disconnected' || $self->status eq 'offline') {
return undef;
}
# If GA::Obj::Telnet's error message is one we recognise, use our own error message
if (
$errorMsg =~ m/Name or service not known/i
|| $errorMsg =~ m/Unknown (remote|local) host/i
) {
if ($self->mxpRelocateMode eq 'none') {
$self->writeText(
'Unrecognised host \'' . $self->initHost . '\'',
$self->_objClass . '->connectionError',
);
} else {
# During an MXP crosslinking operation, show a longer message so the user isn't
# left bewildered by a sudden disconnection message when the world specified a
# <QUIET> relocation
$self->writeText(
'Relocation to new server failed, unrecognised host \''
. $self->mxpRelocateHost . '\'',
$self->_objClass . '->connectionError',
);
}
# React to the disconnection. The TRUE flag means that we've already displayed a message
$self->reactDisconnect(TRUE);
} elsif ($errorMsg =~ m/problem connecting.*connection refused/i) {
if ($self->mxpRelocateMode eq 'none') {
$self->writeText(
'Connection to \'' . $self->initHost . '\' refused',
$self->_objClass . '->connectionError',
);
} else {
$self->writeText(
'Relocation to new server failed, connection to \'' . $self->mxpRelocateHost
. '\' refused',
$self->_objClass . '->connectionError',
);
}
# React to the disconnection
$self->reactDisconnect(TRUE);
} elsif ($errorMsg =~ m/problem connecting.*connect timed\-out/i) {
if ($self->mxpRelocateMode eq 'none') {
$self->writeText(
'Connection to \'' . $self->initHost . '\' timed out',
$self->_objClass . '->connectionError',
);
} else {
$self->writeText(
'Relocation to new server failed, connection to \'' . $self->initHost
. '\' timed out',
$self->_objClass . '->connectionError',
);
}
# React to the disconnection
$self->reactDisconnect(TRUE);
} else {
# Otherwise, use the error message GA::Obj::Telnet gave us
$self->writeError(
ucfirst($errorMsg),
$self->_objClass . '->connectionError',
);
lib/Games/Axmud/Session.pm view on Meta::CPAN
($data >= 0 && $data <= 7)
|| ($data >= 10 && $data <= 12)
|| ($data >= 19 && $data <= 99)
)
) {
# Invalid MXP escape sequence; ignore it
$self->mxpDebug(
$token,
'Invalid value \'' . $data . '\' in MXP escape sequence (expected 0-7,'
. ' 10-12, 19, 20-99)',
1501,
);
return @emptyList;
}
# Process the sequence (modes 0-7 are the most frequent)
if ($data <= 7) {
# 0-7: Line mode escape sequences
if ($data >= 0 && $data <= 2) {
# 0 - Open line, 1 - Secure line, 2 - Locked line
push (@tagList, $self->setMxpLineMode($data));
$self->ivUndef('mxpTempMode');
} elsif ($data == 3) {
# 3 - Reset
# Close all open tags
push (@tagList, $self->emptyMxpStack());
# Update IVs
push (@tagList, $self->setMxpLineMode(0));
$self->ivPoke('mxpDefaultMode', 0);
$self->ivUndef('mxpTempMode');
} elsif ($data == 4) {
# 4 - Temp secure mode
$self->ivPoke('mxpTempMode', $self->mxpLineMode);
push (@tagList, $self->setMxpLineMode(1, TRUE));
} elsif ($data >= 5 && $data <= 7) {
# 5 - Lock open mode, 6 - Lock secure mode, 7 - Lock locked mode
$self->ivPoke('mxpDefaultMode', $data);
$self->ivUndef('mxpTempMode');
push (@tagList, $self->setMxpLineMode($data - 5));
}
} elsif ($data >=10 && $data <= 12) {
# Room modes
push (@tagList, 'mxpm_' . $data); # e.g. 'mxpm_10'
} elsif ($data == 19) {
# Welcome text
push (@tagList, 'mxpm_19');
# ...which is not displayed during an MXP relocate operation
if ($self->mxpRelocateMode ne 'none') {
$self->ivPoke('mxpRelocateQuietLineFlag', TRUE);
}
} elsif ($data >= 20 && $data <= 99) {
# User-defined modes
push (@tagList, 'mxpm_' . $data); # e.g. 'mxpm_20'
}
} elsif ($type eq 'sgr') {
# VT100 SGR (Select Graphic Rendition) escape sequences in the form
# ESC [ Value ; ... ; Value m
# Extract the value(s)
# A list of integers separated by ';' characters
$data = substr($data, 0, (length($data) - 1));
# Some worlds (e.g. Viking MUD) use the escape sequence 'Esc [ m' instead of 'Esc [ 0 m'
# Convert the former to the latter, if found
if (! $data) {
$data = '0';
}
# $data is in the form 'Value;...;Value'. where Value is in the range 0-1, 3-9, 22-25,
# 27-29, 30-39, 40-49
@valueList = split(/;/, $data);
# It's valid to use 'Value's with leading 0s. Remove the leading zeros
foreach my $value (@valueList) {
if ($value =~ m/^\d+$/) {
$value += 0;
}
}
# NB We're using 'eq' rather than '==' to prevent a Perl error, if we analyse a sequence
# containing 'ESC [ 1 , 31 m' rather than the correct 'ESC [ 1 ; 31 m', or even if the
# string contains invalid non-numerical characters
#
# Special case: xterm-256 colours will set @valueList to (38, 5, n) or (48, 5, n)
# (corresponding to escape sequences 'ESC [ 38 ; 5 ; n m' and 'ESC [ 48 ; 5 ; n m').
# In this case, @valueList must contain exactly 3 values
if ($valueList[0] eq '38' || $valueList[0] eq '48') {
# If it's not a valid sequence, ignore it
if (
scalar @valueList == 3
&& $valueList[1] eq '5'
&& $axmud::CLIENT->ivExists('xTermColourHash', 'x' . $valueList[2])
) {
if ($valueList[0] eq '38') {
push (@tagList, 'x' . $valueList[2]); # e.g. 'x255'
} else {
push (@tagList, 'ux' . $valueList[2]); # e.g. 'ux255'
}
}
lib/Games/Axmud/Session.pm view on Meta::CPAN
delete $tagHash{'h5'};
delete $tagHash{'h6'};
delete $tagHash{'small'};
delete $tagHash{'tt'};
# If FALSE, <FONT> tags can still change the text colour
%tagHash = $self->deleteMxpAttrib('font', 'face', %tagHash);
%tagHash = $self->deleteMxpAttrib('font', 'size', %tagHash);
}
if (! $axmud::CLIENT->allowMxpImageFlag) {
delete $tagHash{'image'};
}
if (! $axmud::CLIENT->allowMxpLoadImageFlag) {
%tagHash = $self->deleteMxpAttrib('image', 'url', %tagHash);
}
if (! $axmud::CLIENT->allowMxpFilterImageFlag) {
delete $tagHash{'filter'};
}
if (! $axmud::CLIENT->allowSoundFlag || ! $axmud::CLIENT->allowMxpSoundFlag) {
delete $tagHash{'sound'};
delete $tagHash{'music'};
}
# (No need to use GA::Client->allowMxpLoadSoundFlag here)
if (
! $axmud::CLIENT->allowMxpGaugeFlag
|| ! $self->mainWin->ivShow('firstStripHash', 'Games::Axmud::Strip::GaugeBox')
) {
delete $tagHash{'gauge'};
delete $tagHash{'stat'};
}
if (
$axmud::BLIND_MODE_FLAG
|| ! $axmud::CLIENT->allowMxpFrameFlag
|| $self->mxpDisableFrameFlag
) {
delete $tagHash{'frame'};
# (Axmud chooses to ignore <DEST> tags if frames have been disabled generally; even
# though some world might want cursor control in the main MUD window, that's not very
# practical if it's scrolling)
delete $tagHash{'dest'};
}
if ($axmud::CLIENT->shareMainWinFlag || ! $axmud::CLIENT->allowMxpInteriorFlag) {
%tagHash = $self->deleteMxpAttrib('frame', 'internal', %tagHash);
}
if (! $axmud::CLIENT->allowMxpCrosslinkFlag) {
delete $tagHash{'relocate'};
}
# Process the <SUPPORT> tag
if (! @argList) {
# Return a list of all supported tags
$msg = '<SUPPORTS';
foreach my $key (sort {$a cmp $b} (keys %tagHash)) {
$msg .= ' +' . uc($key);
}
$msg .= '>';
# The response must be sent securely
$self->optSendMxpSecure($msg);
} else {
# Respond to every item in @argList
$msg = '<SUPPORTS';
do {
my ($argName, $argValue, $tag, $attrib, $listRef);
$argName = shift @argList;
$argValue = shift @argList; # Should be 'undef'; ignored, in any case
# Remove the initial/final quotation marks, if present
$argName =~ s/^\"//;
$argName =~ s/\"$//;
# Split the item into its component parts
# e.g. <SUPPORT color.*> > ('color', '*')
# e.g. <SUPPORT send.expire> > ('send', 'expire')
if ($argName =~ m/(\w+)\.(.*)/) {
$tag = lc($1);
$attrib = lc($2);
# e.g. <SUPPORT image> > ('image')
} else {
$tag = lc($argName);
}
# Convert a long tag to its abbreviation (e.g. <DESTINATION> to <DEST>)
if ($axmud::CLIENT->ivExists('constMxpConvertHash', uc($tag))) {
$tag = lc($axmud::CLIENT->ivShow('constMxpConvertHash', uc($tag)));
}
# Check the MXP is both recognised and currently supported
if (! exists $tagHash{$tag}) {
$msg .= ' -' . $tag;
lib/Games/Axmud/Session.pm view on Meta::CPAN
if (
($tagMode eq 'open' && ! @argList)
|| ($tagMode eq 'close' && @argList)
|| $tagMode eq 'defn'
) {
$self->mxpDebug($origToken, 'Malformed element', 3501);
return @emptyList;
}
# Ignore this tag if the client flag is set
if (! $axmud::CLIENT->allowMxpCrosslinkFlag) {
return @emptyList;
}
if ($tagMode eq 'open') {
# Process @argList
@origList = @checkList = ('hostname', 'port');
# Hash of argument names which don't take a corresponding value
%checkHash = ();
# Default argument values
%ivHash = (
'hostname' => undef,
'port' => undef,
);
do {
my ($argName, $argValue) = $self->findMxpArgsByPosn(
\@origList,
\@checkList,
\%ivHash,
\%checkHash,
shift @argList, # not 'undef'
shift @argList, # might be 'undef'
);
if (! defined $argName) {
# Unrecognised argument name, or repeating argument name
$self->mxpDebug($origToken, 'Malformed element', 3502);
return @emptyList;
} else {
$ivHash{$argName} = $argValue;
}
} until (! @argList);
# We'll let the hostname be anything, but the port should at least be a valid integer
# in the usual range
if (
! $ivHash{'hostname'}
|| ! defined $ivHash{'port'}
|| ! $axmud::CLIENT->floatCheck($ivHash{'port'}, 0, 65535)
) {
$self->mxpDebug($origToken, 'Invalid relocation hostname and/or port', 3511);
return @emptyList;
}
# Don't allow a crosslink operation if one is already in progress, or if a delayed
# quit has been set up
if ($self->mxpRelocateMode eq 'none' && ! defined $self->delayedQuitTime) {
# The crosslinking process will start on the next incoming data loop (allowing the
# server to send a <QUIET> tag right after this one
$self->ivPoke('mxpRelocateMode', 'wait_start');
$self->ivPoke('mxpRelocateHost', $ivHash{'hostname'});
$self->ivPoke('mxpRelocatePort', $ivHash{'port'});
}
} else {
# Mark the character as logged in, if it isn't already (this sets
# $self->mxpRelocateMode to 'none', which terminates the crosslinking operation)
$self->doLogin();
}
return @emptyList;
}
sub processMxpLoginElement {
# Called by $self->processMxpElement
#
# Process an MXP login element: <USER>, <PASSWORD>
#
# Expected arguments
# $origToken - The original token text, before anything was extracted
# $tagMode - 'open' for <..> elements, 'close' for </..> elements, 'defn' for <!..>
# elements
# $keyword - The element keyword (already converted to upper case)
#
# Optional arguments
# @argList - If the element has arguments, a list in the form
# (arg_name, arg_value, arg_name, arg_value...)
# ...where each 'arg_value' is 'undef' is the argument wasn't a name=value
# construction
#
# Return values
# An empty list on improper arguments
# Otherwise returns an equivalent list of Axmud colour/style tags otherwise (may be an
# empty list)
my ($self, $origToken, $tagMode, $keyword, @argList) = @_;
# Local variables
my @emptyList;
# Check for improper arguments
if (! defined $origToken || ! defined $tagMode || ! defined $keyword) {
$axmud::CLIENT->writeImproper($self->_objClass . '->processMxpLoginElement', @_);
return @emptyList;
}
( run in 0.444 second using v1.01-cache-2.11-cpan-5511b514fd6 )