Games-Axmud
view release on metacpan or search on metacpan
lib/Games/Axmud/Client.pm view on Meta::CPAN
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' on improper arguments
# Blessed reference to the newly-created object on success. The calling function sets the
# $CLIENT global variable
my ($class, $check) = @_;
# Local variables
my (
$urlRegex, $shortRegex, $emailRegex,
@cmdList,
%soundHash, %msspHash,
);
# Check for improper arguments
if (! defined $class || defined $check) {
# Global variable $axmud::CLIENT not set yet, so we'll just have to print the
# improper arguments message
print "IMPROPER ARGUMENTS: Games::Axmud::Client->new " . join(' ', @_) . "\n";
return undef;
}
# Set regexes to recognise URLs
$urlRegex = 'http(s?)\:\/\/[0-9a-zA-Z]([-.\w]*[0-9a-zA-Z])*(:(0-9)*)*(\/?)'
. '([a-zA-Z0-9\-?\.\?\,\'\/\\\+&%\$#_\=\~]*)?';
$shortRegex = '[0-9a-zA-Z]([-.\w]*[0-9a-zA-Z])*\.(com|org|net|int|edu|gov|mil|io|uk)';
# Set a regex to recognise email addresses
$emailRegex = '\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b';
# Setup
my $self = {
_objName => 'client',
_objClass => $class,
_parentFile => undef, # No parent file object
_parentWorld => undef, # No parent file object
_privFlag => TRUE, # All IVs are private
# Perl object components
# ----------------------
# The main desktop object (GA::Obj::Desktop), which arranges windows on the desktop
# across one or more workspaces
desktopObj => undef,
# An IV which stores a 'main' window. First set when Axmud starts, and a spare 'main'
# window, not belonging to any session, opens before the Connections window opens
# Briefly set back to 'undef' when the spare 'main' window is destroyed, just before a
# new 'main' window for a new session is created to replace it
# Then set whenever $self->currentSession is set
mainWin => undef,
# The About window (only one can be open at a time)
aboutWin => undef, # Set by $self->set_aboutWin
# A 'dialogue' window created by a call to GA::Generic::Win->showBusyWin, e.g. the
# 'Loading...' window created by $self->start
busyWin => undef, # Set by $self->set_busyWin
# The Connections window (only one can be open at a time)
connectWin => undef, # Set by $self->set_connectWin
# The Client Console window (only one can be open at a time)
consoleWin => undef, # Set by $self->set_consoleWin
# Instance variable constants
# ---------------------------
# All of Axmud's Perl objects have instance variables (IVs); the vast majority of them
# are either scalar IVs (including references stored in scalar variables), list IVs or
# hash IVs. There are a few more complex structures (e.g. arrays of arrays, hashes of
# arrays, etc), but besides that, there no other data structures (globs, etc)
#
# All objects have five standard 'constant' IVs which should not be modified, namely
# ->_objName, ->_objClass, ->_parentFile, ->_parentWorld and ->privFlag.
# ->_objName gives a name to an object, even if it doesn't have a ->name IV.
# ->_objName is not necessarily unique
# ->_objectClass is the same as the package name for the object (e.g. GA::Client)
# ->_parentFile matches a key in the file object registry, $self->fileObjHash (see
# further below). It tells us which data file is used to save this object. (A few
# objects don't have a parent file; in these casees, ->_parentFile is set to 'undef')
# ->_parentWorld is the name of the current world profile, in the GA::Session to which
# the object belongs. (Some objects don't belong to a particular GA::Session; in these
# cases, ->_parentWorld is set to 'undef')
# ->_privFlag is set to TRUE if the object's IVs are private; FALSE if they are public.
# (See the comments at the top of generic_obj.pm)
#
# In addition, any IV whose name begins with 'const' is treated as a constant value
# which should not be modified
#
# The generic object, Games::Axmud, from which all Axmud objects inherit, provides
# several useful functions for accessing and storing values for all IVs, such as
# ->ivPush, ->ivSplice and ->ivPeek
# The most important one is ->ivPoke. When an IV's value (or values) are set, it should
# not be done with a call to
# $self->{iv_name} = $value
# but with a call to
# $self->ivPoke('iv_name', $value)
# ->ivPoke (like all the generic object's IV functions) tells the equivalent
# GA::Obj::File that its data has been modified, and that it needs to be saved
# ->ivPoke, etc, can't be used to modify constant IVs (the five mentioned above, and any
# IV whose names starts 'const'
#
# Constant registry hash of constant instance variables (IVs) required by every Perl
# object. A hash in the form
# $constIVHash{iv_name} = undef
constIVHash => {
'_objName' => undef,
'_objClass' => undef,
'_parentFile' => undef,
'_parentWorld' => undef,
'_privFlag' => undef,
},
# Constant registry hash of reserved names that can't be used by profiles and other
# Perl objects which have unique names (case-insensitive; these values never change)
# Hash in the form
# $constReservedHash{string} = undef
# NB Plurals have been added only when necessary, specifically because there's a file
# object with a name in the plural
constReservedHash => {
lib/Games/Axmud/Client.pm view on Meta::CPAN
# Load data for the remaining file objects ('tasks', 'scripts', 'contacts', 'dicts',
# 'toolbar', 'usercmds', 'zonemaps', 'winmaps', 'tts')
if ($self->loadDataFlag && ! $self->loadOtherFiles()) {
$warningFlag = TRUE;
$self->writeWarning(
'Error reading (or creating) data files - loading/saving disabled',
$self->_objClass . '->start',
);
# Disable all loading/saving of data files (the TRUE argument means 'don't prompt the
# user to do an emergency save')
$self->disableAllFileAccess(TRUE);
}
# Add remaining workspaces, if any are specified
$desktopObj->setupWorkspaces();
# Set up client commands
if (! $self->setupCmds()) {
# (Allow writing to something other than GA::Session - there are no sessions yet)
return $self->writeError(
'Could not initialise ' . $axmud::SCRIPT . ' client commands',
$self->_objClass . '->start',
);
}
# Delete the contents of log directories (leaving files inside worlds' own log directories
# intact), if the flag is set (but don't delete directories if this function has produced
# any warning messages - so that the messages aren't lost
if ($self->deleteStandardLogsFlag && ! $warningFlag) {
$self->deleteStandardLogs();
}
# Load plugins in the /private directory, if it exists (will not exist in any public release
# of Axmud)
if (-e $axmud::SHARE_DIR . '/private') {
$self->loadPrivatePlugins();
}
# Load initial plugins
if ($self->initPluginList) {
foreach my $pluginPath ($self->initPluginList) {
if (! $self->loadPlugin($pluginPath)) {
$self->writeWarning(
'Error loading the plugin \'' . $pluginPath . '\'',
$self->_objClass . '->start',
);
}
}
}
# Close the 'dialogue' window and reset the Client IV that stores it
if ($self->busyWin) {
$self->mainWin->closeDialogueWin($self->busyWin);
}
# Start the client loop
if (! $self->startClientLoop()) {
return $self->writeError(
'Could not start the client loop',
$self->_objClass . '->start',
);
}
# Prepare to initialise connections
if ($self->showSetupWizWinFlag) {
# When Axmud runs for the first time (specifically, when there is no Axmud config file)
# this flag will be set to TRUE, instructing us to open the Setup 'wiz' window so the
# new user can initialise a few settings
if ($axmud::TEST_MODE_FLAG) {
# In Axmud test mode, don't show the Setup window at all; just insert a couple of
# tasks into the global initial tasklist
$self->addGlobalInitTask('status_task');
$self->addGlobalInitTask('locator_task');
# Don't show the setup window twice
$self->set_showSetupWizWinFlag(FALSE);
} elsif ($axmud::BLIND_MODE_FLAG) {
# In Axmud blind mode, don't show the Setup window at all; instead, insert a few
# tasks into the global initial tasklist, and modify a few of their settings
# (specifically, none of them open a task window)
$taskObj = $self->addGlobalInitTask('status_task');
if ($taskObj) {
$taskObj->set_startWithWinFlag(FALSE);
}
$taskObj = $self->addGlobalInitTask('locator_task');
if ($taskObj) {
$taskObj->set_startWithWinFlag(FALSE);
}
$taskObj = $self->addGlobalInitTask('compass_task');
if ($taskObj) {
$taskObj->set_startWithWinFlag(FALSE);
}
$taskObj = $self->addGlobalInitTask('divert_task');
if ($taskObj) {
$taskObj->set_requireWinFlag(FALSE);
$taskObj->set_startWithWinFlag(FALSE);
# Turn off sound effects, since TTS is used instead
$taskObj->ivUndef('tellAlertSound');
$taskObj->ivUndef('socialAlertSound');
$taskObj->ivUndef('customAlertSound');
$taskObj->ivUndef('warningAlertSound');
lib/Games/Axmud/Client.pm view on Meta::CPAN
$fileName = $axmud::NAME_FILE . '_backup_' . $axmud::CLIENT->localDateString() . '_'
. $axmud::CLIENT->localClockString() . '.' . $ext;
}
# If necessary, open a file chooser dialog to decide where to save the exported file
if ($self->autoBackupDir && -e $self->autoBackupDir) {
$backupPath = $self->autoBackupDir;
} else {
$backupPath = $self->mainWin->showFileChooser(
'Backup ' . $axmud::SCRIPT . ' data',
'save',
$fileName,
);
}
if (! $backupPath) {
return undef;
}
# Display a 'dialogue' window while backing up data. The 'undef' argument means 'show the
# standard icon'
if (! $axmud::BLIND_MODE_FLAG) {
$self->mainWin->showBusyWin(undef, 'Backing up...');
}
# Get a list of files in the data directory, recursively searching sub-directories
File::Find::find(
sub { push (@fileList, $File::Find::name); },
$dataDir . '/',
);
# Perform the backup
if ($ext eq 'zip') {
# Create a zip object
$zipObj = Archive::Zip->new();
foreach my $file (@fileList) {
my $modFile;
if ($file ne $dataDir) {
$modFile = $file;
$modFile =~ s/$dataDir//;
# 6 is the default compression level
$zipObj->addFile($file, $modFile, 6);
}
}
# Save the .zip file. Successful operation returns 0
if ($zipObj->writeToFileNamed($backupPath)) {
# Close the 'dialogue' window and reset the Client IV that stores it
if ($self->busyWin) {
$self->mainWin->closeDialogueWin($self->busyWin);
}
return undef;
}
} else {
# Create a tar object
$tarObj = Archive::Tar->new();
foreach my $file (@fileList) {
if ($file ne $dataDir) {
$tarObj->add_files($file);
# Rename each file in the archive to remove the directory structure
$tarObj->rename(substr($file, 1), substr($file, length($dataDir)));
}
}
# Save the .tgz file
if (
! $tarObj->write(
$backupPath,
Archive::Tar::COMPRESS_GZIP,
$axmud::NAME_SHORT . '-data',
)
) {
# Close the 'dialogue' window and reset the Client IV that stores it
if ($self->busyWin) {
$self->mainWin->closeDialogueWin($self->busyWin);
}
return undef;
}
}
# Operation successful. Update IVs so the next scheduled auto-backup occurs on time
if ($self->autoBackupMode eq 'all_start' || $self->autoBackupMode eq 'all_stop') {
# No scheduled auto-backups; auto-backups occur when Axmud starts/stops
$self->ivUndef('autoBackupDate');
} else {
# Scheduled auto-backups
$self->ivPoke('autoBackupDate', $self->localDate());
}
# Close the 'dialogue' window and reset the Client IV that stores it
if ($self->busyWin) {
$self->mainWin->closeDialogueWin($self->busyWin);
}
return 1;
}
# General-purpose methods
sub nameCheck {
# Checks whether a name for a Perl object matches Axmud's naming rules (namely, must be
# between 1 to $maxLength characters, containing letters, numbers and underlines -
# first character can't be a number. International characters, e.g. those in Cyrillic,
# are accepted)
# Also checks that the name doesn't clash with one of Axmud's reserved words
#
# Expected arguments
# $name - the name (string) to be tested
# $maxLength - the maximum string length allowed
#
# Return values
# 'undef' on improper arguments or if $name is not valid, according to Axmud's naming
# rules
# 1 if $name is acceptable
my ($self, $name, $maxLength, $check) = @_;
# Check for improper arguments
if (! defined $name || ! defined $maxLength || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->nameCheck', @_);
}
# Check reserved words
if ($self->ivExists('constReservedHash', lc($name))) {
return undef;
}
# Perform the check
$maxLength--;
if (! ($name =~ m/^[[:alpha:]\_]{1}[[:word:]]{0,$maxLength}$/)) {
return undef;
} else {
return 1;
}
}
sub intCheck {
# Checks whether a value is an integer, or not
#
# Expected arguments
# (none besides $self)
#
# Optional arguments
# $num - A value to test. If 'undef' or an empty string, no value is tested (and
# no error message is produced)
# $min - If defined, a minimum value. Can be zero or any floating-point number,
# positive or negative (but will usually be another integer)
lib/Games/Axmud/Client.pm view on Meta::CPAN
my ($self, $flag, $check) = @_;
# Check for improper arguments
if (! defined $flag || defined $check) {
return $axmud::CLIENT->writeImproper(
$self->_objClass . '->set_blindHelpMsgShownFlag',
@_,
);
}
if ($flag) {
$self->ivPoke('blindHelpMsgShownFlag', TRUE);
} else {
$self->ivPoke('blindHelpMsgShownFlag', FALSE);
}
# The data stored in this IV is saved in the 'config' file
$self->setModifyFlag('config', TRUE, $self->_objClass . '->set_blindHelpMsgShownFlag');
return 1;
}
sub set_blockWorldHintFlag {
my ($self, $flag, $check) = @_;
# Check for improper arguments
if (! defined $flag || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->set_blockWorldHintFlag', @_);
}
if ($flag) {
$self->ivPoke('blockWorldHintFlag', TRUE);
} else {
$self->ivPoke('blockWorldHintFlag', FALSE);
}
return 1;
}
sub set_browserCmd {
my ($self, $cmd, $check) = @_;
# Check for improper arguments
if (! defined $cmd || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->set_browserCmd', @_);
}
$self->ivPoke('browserCmd', $cmd);
# The data stored in this IV is saved in the 'config' file
$self->setModifyFlag('config', TRUE, $self->_objClass . '->set_browserCmd');
return 1;
}
sub set_busyWin {
my ($self, $winObj, $check) = @_;
# Check for improper arguments
if (defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->set_busyWin', @_);
}
# Update IVs
$self->ivPoke('busyWin', $winObj);
return 1;
}
sub set_chatAcceptMode {
my ($self, $mode, $check) = @_;
# Check for improper arguments
if (
! defined $mode
|| ($mode ne 'prompt' && $mode ne 'accept_contact' && $mode ne 'accept_all')
|| defined $check
) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->set_chatAcceptMode', @_);
}
$self->ivPoke('chatAcceptMode', $mode);
# The data stored in this IV is saved in the 'contacts' file
$self->setModifyFlag('contacts', TRUE, $self->_objClass . '->set_chatAcceptMode');
return 1;
}
sub add_chatContact {
my ($self, $name, $obj, $check) = @_;
# Check for improper arguments
if (! defined $name || ! defined $obj || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->add_chatContact', @_);
}
$self->ivAdd('chatContactHash', $name, $obj);
# The data stored in this IV is saved in the 'contacts' file
$self->setModifyFlag('contacts', TRUE, $self->_objClass . '->add_chatContact');
return 1;
}
sub del_chatContact {
my ($self, $name, $check) = @_;
# Check for improper arguments
if (! defined $name || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->del_chatContact', @_);
}
$self->ivDelete('chatContactHash', $name);
# The data stored in this IV is saved in the 'contacts' file
$self->setModifyFlag('contacts', TRUE, $self->_objClass . '->del_chatContact');
return 1;
}
lib/Games/Axmud/Client.pm view on Meta::CPAN
} else {
$self->ivAdd('zmpPackageHash', $obj->name, $obj);
return $obj;
}
}
sub add_zonemap {
my ($self, $obj, $check) = @_;
# Check for improper arguments
if (! defined $obj || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->add_zonemap', @_);
}
# Update IVs
$self->ivAdd('zonemapHash', $obj->name, $obj);
# The data stored in this IV is saved in the 'zonemaps' file
$self->setModifyFlag('zonemaps', TRUE, $self->_objClass . '->add_zonemap');
return 1;
}
sub del_zonemap {
# Called by GA::Cmd::DeleteZonemap->do and, for temporary zonemaps, GA::Session->stop
# (only; if a zonemap in use by a workspace grid is deleted, bad things can happen)
my ($self, $zonemapName, $check) = @_;
# Check for improper arguments
if (! defined $zonemapName || defined $check) {
return $axmud::CLIENT->writeImproper($self->_objClass . '->del_zonemap', @_);
}
# Update IVs
$self->ivDelete('zonemapHash', $zonemapName);
# The data stored in this IV is saved in the 'zonemaps' file
$self->setModifyFlag('zonemaps', TRUE, $self->_objClass . '->del_zonemap');
return 1;
}
##################
# Accessors - get
sub desktopObj
{ $_[0]->{desktopObj} }
sub mainWin
{ $_[0]->{mainWin} }
sub aboutWin
{ $_[0]->{aboutWin} }
sub busyWin
{ $_[0]->{busyWin} }
sub connectWin
{ $_[0]->{connectWin} }
sub consoleWin
{ $_[0]->{consoleWin} }
sub constIVHash
{ my $self = shift; return %{$self->{constIVHash}}; }
sub constReservedHash
{ my $self = shift; return %{$self->{constReservedHash}}; }
sub loadConfigFlag
{ $_[0]->{loadConfigFlag} }
sub saveConfigFlag
{ $_[0]->{saveConfigFlag} }
sub loadDataFlag
{ $_[0]->{loadDataFlag} }
sub saveDataFlag
{ $_[0]->{saveDataFlag} }
sub deleteFilesAtStartFlag
{ $_[0]->{deleteFilesAtStartFlag} }
sub fileFailFlag
{ $_[0]->{fileFailFlag} }
sub emergencySaveFlag
{ $_[0]->{emergencySaveFlag} }
sub autoSaveFlag
{ $_[0]->{autoSaveFlag} }
sub autoSaveWaitTime
{ $_[0]->{autoSaveWaitTime} }
sub autoRetainFileFlag
{ $_[0]->{autoRetainFileFlag} }
sub autoBackupMode
{ $_[0]->{autoBackupMode} }
sub autoBackupDir
{ $_[0]->{autoBackupDir} }
sub autoBackupInterval
{ $_[0]->{autoBackupInterval} }
sub autoBackupDate
{ $_[0]->{autoBackupDate} }
sub autoBackupFileType
{ $_[0]->{autoBackupFileType} }
sub autoBackupAppendFlag
{ $_[0]->{autoBackupAppendFlag} }
sub fileObjHash
{ my $self = shift; return %{$self->{fileObjHash}}; }
sub configFileObj
{ $_[0]->{configFileObj} }
sub configWorldProfList
{ my $self = shift; return @{$self->{configWorldProfList}}; }
sub constLargeFileSize
{ $_[0]->{constLargeFileSize} }
sub allowModelSplitFlag
{ $_[0]->{allowModelSplitFlag} }
sub constModelSplitSize
{ $_[0]->{constModelSplitSize} }
( run in 1.056 second using v1.01-cache-2.11-cpan-39bf76dae61 )