Games-Axmud
view release on metacpan or search on metacpan
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('testmodel', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['tmd', 'testmodel'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Performs an integrity check on the world model';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch,
$check,
) = @_;
# Local variables
my (
$errorCount, $fixCount,
@outputList,
);
# Check for improper arguments
if ((defined $switch && $switch ne '-f') || defined $check) {
return $self->improper($session, $inputString);
}
# It might be a long wait, so make sure the message is visible right away
$session->writeText('Testing \'' . $session->currentWorld->name . '\' world model...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Perform the test
if ($switch) {
($errorCount, $fixCount, @outputList) = $session->worldModelObj->testModel(
$session,
TRUE, # Fix problems
TRUE, # Use a list of return values
);
} else {
($errorCount, $fixCount, @outputList) = $session->worldModelObj->testModel(
$session,
FALSE, # Don't problems
TRUE, # Use a list of return values
);
}
# That's the end of the test
# Display any output. If a very large number of error messages have been generated, don't
# show all of them
if ((scalar @outputList) > 100) {
$session->writeText((scalar @outputList) . ' error messages; curtailing output');
for (my $index = 0; $index < 100; $index++) {
$session->writeText($outputList[$index]);
}
} else {
foreach my $msg (@outputList) {
$session->writeText($msg);
}
}
return $self->complete(
$session, $standardCmd,
'World model integrity check complete (errors: ' . $errorCount . ', fixes '
. $fixCount . ')',
);
}
}
{ package Games::Axmud::Cmd::TestPattern;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('togglelabel', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['tlb', 'togglelabel'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Toggles toolbar button labels';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
) = @_;
# Local variables
my $string;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# ;tlb
if (! $axmud::CLIENT->toolbarLabelFlag) {
$axmud::CLIENT->set_toolbarLabelFlag(TRUE);
$string = 'ON';
} else {
$axmud::CLIENT->set_toolbarLabelFlag(FALSE);
$string = 'OFF';
}
# Update all 'main' and automapper windows
foreach my $winObj ($axmud::CLIENT->desktopObj->ivValues('gridWinHash')) {
my $stripObj;
if ($winObj->winType eq 'main') {
$stripObj = $winObj->getStrip('toolbar');
if ($stripObj) {
$stripObj->resetToolbar();
}
} elsif ($winObj->winType eq 'map') {
$winObj->redrawWidgets('menu_bar', 'toolbar', 'treeview', 'canvas');
}
}
return $self->complete(
$session, $standardCmd,
'Toolbar button labels turned ' . $string,
);
}
}
{ package Games::Axmud::Cmd::ToggleIrreversible;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('toggleirreversible', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['tir', 'toggleir', 'toggleirreversible'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Toggles irreversible icons in \'edit\' windows';
# Bless the object into existence
bless $self, $class;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
$otherHash{'scripts'} = undef;
}
if ($contactsFlag) {
$otherHash{'contacts'} = undef;
}
if ($dictsFlag) {
$otherHash{'dicts'} = undef;
}
if ($toolbarFlag) {
$otherHash{'toolbar'} = undef;
}
if ($userCmdFlag) {
$otherHash{'usercmds'} = undef;
}
if ($zonemapsFlag) {
$otherHash{'zonemaps'} = undef;
}
if ($winmapsFlag) {
$otherHash{'winmaps'} = undef;
}
if ($ttsFlag) {
$otherHash{'tts'} = undef;
}
# Check to be safe - check at least one file has been marked for saving
if (! %worldHash && ! %otherHash) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->complete($session, $standardCmd, 'No files to save');
}
# Saves the files in the order (1) 'config', (2) world profiles, (3) 'otherprof', (4)
# everything else
$count = 0;
$errorCount = 0;
# For large files (e.g. world models containing tens of thousands of rooms), we need to
# display an initial message to explain the pause
# However, in blind mode don't display a message at all; speech engine struggle to read
# 'file(s)' correctly, and those users are probably not using the automapper anyway, so
# file saves will be more or less instantaneous
if (! $axmud::BLIND_MODE_FLAG) {
$session->writeText('Saving file(s)...');
}
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# (1) 'config'
if (exists $otherHash{'config'}) {
my $fileObj = $fileObjHash{'config'};
if ($fileObj->modifyFlag || $forceFlag) {
if ($fileObj->saveConfigFile()) {
$count++;
} else {
$errorCount++;
}
}
# Only save it once
delete $otherHash{'config'};
}
# (2) world profiles
foreach my $file (keys %worldHash) {
my $fileObj = $fileObjHash{$file};
if ($fileObj->modifyFlag || $forceFlag) {
if ($fileObj->saveDataFile()) {
$count++;
} else {
$errorCount++;
}
}
}
# (3) 'otherprof'
if (exists $otherHash{'otherprof'}) {
my $fileObj = $session->ivShow('sessionFileObjHash', 'otherprof');
if ($fileObj->modifyFlag || $forceFlag) {
if ($fileObj->saveDataFile()) {
$count++;
} else {
$errorCount++;
}
}
# Only save it once
delete $otherHash{'otherprof'};
}
# (4) everything else
OUTER: foreach my $file (keys %otherHash) {
my $fileObj;
if (exists $fileObjHash{$file}) {
$fileObj = $fileObjHash{$file};
} else {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# Count how many of the selected files are marked as needing to be saved (so that loading
# the file would cause the data in memory to be lost)
$count = 0;
$loadCount = 0;
foreach my $file (keys %loadHash) {
my $fileObj;
$loadCount++;
if ($file eq 'worldmodel') {
$fileObj = $session->ivShow('sessionFileObjHash', $file);
} else {
$fileObj = $axmud::CLIENT->ivShow('fileObjHash', $file);
}
if ($fileObj && $fileObj->modifyFlag) {
$count++;
}
}
# Ask for permission to load any files that will cause data in memory to be lost
if ($count) {
if ($count == 1 && $loadCount == 1) {
$msg = 'The file you have specified will overwrite unsaved data in memory. Load'
. ' it anyway?';
} elsif ($count != 1 && $loadCount == 1) {
$msg = '1 of the files you have specified will overwrite unsaved data in'
. ' memory. Load it anyway?';
} else {
$msg = $count . ' of the ' . $loadCount . ' files you have specified will'
. ' overwite unsaved data in memory. Load them anyway?';
}
$result = $session->mainWin->showMsgDialogue(
'Overwrite unsaved data',
'question',
$msg,
'yes-no',
);
if ($result eq 'no') {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->complete($session, $standardCmd, 'No files loaded');
}
}
# For large files (e.g. world model containing tens of thousands of rooms), we need to
# display an initial message to explain the pause
$session->writeText('Loading file(s)...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Load every file in the hash
$count = 0;
$errorCount = 0;
foreach my $file (keys %loadHash) {
my $fileObj;
if ($file eq 'worldmodel') {
$fileObj = $session->ivShow('sessionFileObjHash', $file);
} else {
$fileObj = $axmud::CLIENT->ivShow('fileObjHash', $file);
}
# Load the file, replacing data stored in memory
if (! $fileObj->loadDataFile()) {
# Try loading the automatic backup, i.e. 'tasks.axm.bu'
if (! $fileObj->loadDataFile(undef, undef, undef, TRUE)) {
$errorCount++;
} else {
$count++;
}
} else {
$count++;
}
}
if ($count == 0 && $errorCount > 0) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error($session, $inputString, 'Files loaded: 0, errors: ' . $errorCount);
} else {
# Multiple sessions can connect to the same world (in online or offline mode) and, in
# that case, GA::Session->setupProfiles uses the same GA::Obj::WorldModel for each
# If a new world model has been loaded, it must be applied to each of those sessions,
# and their automapper objects/windows must be reset
if (exists $loadHash{'worldmodel'}) {
# Calling GA::Session->set_worldModelObj to replace the value with the same value
# has the fortunate effect of handling everything
$session->set_worldModelObj($session->worldModelObj);
}
return $self->complete(
$session, $standardCmd,
'Files loaded: ' . $count . ', errors: ' . $errorCount,
);
}
}
}
{ package Games::Axmud::Cmd::AutoSave;
use strict;
use warnings;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# At the end of this function, when listing the files exported, only
# include the main world model file
$miniFileHash{$miniFile} = undef;
}
} until ($exitFlag);
}
}
}
# Check at least one file has been marked for exporting
if (! @exportList) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->complete($session, $standardCmd, 'No files to export');
}
# Check that all the files in @exportList actually exist
foreach my $file (@exportList) {
if (! (-e $axmud::DATA_DIR . '/' . $file)) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'File not found: ' . $file . ', no files exported',
);
}
}
# Open a file chooser dialog to decide where to save the exported file
# NB Private code, not included in the public release, sets the IV
# GA::Client->privConfigAllWorld, in which case we use a certain file path, rather than
# prompting the user for one
if (! $axmud::CLIENT->privConfigAllWorld) {
$exportPath = $session->mainWin->showFileChooser(
'Export file(s)',
'save',
$axmud::NAME_FILE . '.tgz',
);
if (! $exportPath) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->complete($session, $standardCmd, 'File(s) not exported');
}
} else {
$exportPath = $axmud::SHARE_DIR . '/items/worlds/' . $axmud::CLIENT->privConfigAllWorld
. '/' . $axmud::CLIENT->privConfigAllWorld . '.tgz';
}
# For large files (e.g. world models containing tens of thousands of rooms), we need to
# display an initial message to explain the pause
$session->writeText('Exporting file(s)...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Create a tar object
$tarObj = Archive::Tar->new();
# Save the list of files to the tar object's memory archive
foreach my $file (@exportList) {
my $path = $axmud::DATA_DIR . '/' . $file;
$tarObj->add_files($path);
# Rename each file in the archive to remove the directory structure
$tarObj->rename($path, $file);
}
# Export the files as a .tgz file
if (! $tarObj->write($exportPath, Archive::Tar::COMPRESS_GZIP, 'export')) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->complete($session, $standardCmd, 'No files exported (archive error)');
} else {
# Display list of exported files
# Display header
$session->writeText('List of exported files (destination: ' . $exportPath . ')');
# Display list
foreach my $file (@exportList) {
if (! exists $miniFileHash{$file}) {
# When the world model is exported as multiple files, only show the main file
$session->writeText(' ' . $file);
}
}
# Display footer
$total = (scalar @exportList) - (keys %miniFileHash);
if ($total == 1) {
return $self->complete($session, $standardCmd, '1 file exported to ' . $exportPath);
} else {
return $self->complete(
$session, $standardCmd,
$total . ' files exported to ' . $exportPath,
);
}
}
}
}
{ package Games::Axmud::Cmd::ImportFiles;
use strict;
use warnings;
# use diagnostics;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# Check for improper arguments
if (defined $check) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->improper($session, $inputString);
}
# Check that loading is allowed at all
if (! $axmud::CLIENT->loadDataFlag) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'File load/save is disabled in all sessions',
);
}
# If a file path was not specified, open a file chooser dialog to decide which file to
# import
if (! $importPath) {
$importPath = $session->mainWin->showFileChooser(
'Import file',
'open',
);
if (! $importPath) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->complete($session, $standardCmd, 'File(s) not imported');
}
}
# Check that $importPath is a valid compressed file (ending .tar, .tar.gz, .tgz, .gz, .zip,
# .bz2, .tar.bz2, .tbz or .lzma)
if (
! ($importPath =~ m/\.tar$/)
&& ! ($importPath =~ m/\.tgz$/)
&& ! ($importPath =~ m/\.gz$/)
&& ! ($importPath =~ m/\.zip$/)
&& ! ($importPath =~ m/\.bz2$/)
&& ! ($importPath =~ m/\.tbz$/)
&& ! ($importPath =~ m/\.lzma$/)
) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'File(s) not imported (you specified something that doesn\'t appear to be a'
. ' compressed archive, e.g. a .zip or .tar.gz file)',
);
}
# For large files (e.g. world models containing tens of thousands of rooms), we need to
# display an initial message to explain the pause
$session->writeText('Importing file(s)...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Build an Archive::Extract object
$extractObj = Archive::Extract->new(archive => $importPath);
if (! $extractObj) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'No files imported (file decompression error)',
);
}
# Extract the object to a temporary directory
$tempDir = $axmud::DATA_DIR . '/data/temp';
if (! $extractObj->extract(to => $tempDir)) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'No files imported (file decompression error)',
);
}
# All the files are now in /data/temp/export. Get a list of paths, relative to $tempDir, of
# all the extracted files
@fileList = @{$extractObj->files}; # e.g. export/tasks.axm
# Convert all the paths into absolute paths
foreach my $file (@fileList) {
$file = $axmud::DATA_DIR . '/data/temp/' . $file;
if ($^O eq 'MSWin32') {
$slash = '\\';
$file =~ s/\//$slash/g;
}
}
# Before v1.0.868, 'otherprof.axm' files were called 'otherdefn.amd' files. Change the
# filename of any affected files
foreach my $file (@fileList) {
my $oldFile = $file;
if ($file =~ m/otherdefn\.amd$/) {
$file =~ s/otherdefn\.amd$/otherprof.axm/;
File::Copy::move($oldFile, $file);
}
}
# The world model, if it is large, may have been divided into multiple files - a main one,
# and several 'mini' files containing a limited number of model objects
# Divide @fileList into groups: (1) 'worldprof' files, (2) 'otherprof' files, the main
# 'worldmodel' file and any 'mini' world model files, (3) everything else
# At the same time, remove any files from @fileList which don't seem to be Axmud data files,
# or which are Axmud config files, or which are files that seem to be corrupted
OUTER: foreach my $file (@fileList) {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# ;exd -z <map>
} elsif ($switch eq '-z') {
# Check the zonemap object exists
if (! $axmud::CLIENT->ivExists('zonemapHash', $name)) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'Unknown zonemap object \'' . $name . '\'',
);
}
# ;exd -p <map>
} elsif ($switch eq '-p') {
# Check the winmap object exists
if (! $axmud::CLIENT->ivExists('winmapHash', $name)) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'Unknown winmap object \'' . $name . '\'',
);
}
# ;exd -o <col>
} elsif ($switch eq '-o') {
# Check the colour scheme object exists
if (! $axmud::CLIENT->ivExists('colourSchemeHash', $name)) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'Unknown colour scheme object \'' . $name . '\'',
);
}
# ;exd -x <obj>
} elsif ($switch eq '-x') {
# Check the TTS object exists
if (! $axmud::CLIENT->ivExists('ttsObjHash', $name)) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'Unknown text-to-speech configuration object \'' . $name . '\'',
);
}
}
# For large files (e.g. world models containing tens of thousands of rooms), we need to
# display an initial message to explain the pause
$session->writeText('Exporting data...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# %saveHash doesn't include the data file's header information
# Insert the header information into %saveHash, and then export the data by saving it as a
# file
$exportFile = $axmud::CLIENT->configFileObj->exportDataFile($session, $switch, $name);
if (! $exportFile) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error($session, $inputString, 'No data exported');
} else {
return $self->complete($session, $standardCmd, 'Data exported to ' . $exportFile);
}
}
}
{ package Games::Axmud::Cmd::ImportData;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('importdata', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['imd', 'importdata'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Imports an object (or objects)';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$importPath,
$check,
) = @_;
# Local variables
my ($configObj, $fileType);
# Check for improper arguments
if (defined $check) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->improper($session, $inputString);
}
# Check that loading is allowed at all
if (! $axmud::CLIENT->loadDataFlag) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'File load/save is disabled in all sessions',
);
}
# If a file path was not specified, open a file chooser dialog to decide which file to
# import
if (! $importPath) {
$importPath = $session->mainWin->showFileChooser(
'Import file',
'open',
);
if (! $importPath) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->complete($session, $standardCmd, 'Data not imported');
}
}
# For large files (e.g. world models containing tens of thousands of rooms), we need to
# display an initial message to explain the pause
$session->writeText('Importing data...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Import the data into memory
$fileType = $axmud::CLIENT->configFileObj->importDataFile($session, $importPath);
if (! $fileType) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error($session, $inputString, 'No data imported');
} else {
return $self->complete(
$session, $standardCmd,
'Data imported from \'' . $fileType . '\' file ' . $importPath,
);
}
}
}
{ package Games::Axmud::Cmd::RetainFileCopy;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('retainfilecopy', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['rfc', 'retaincopy', 'retainfilecopy'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Retains copy of old files in file-save operations';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
}
# Check that the data directory actually exists (no reason why it shouldn't, but still we'll
# still check)
if (! -e $dataDir) {
return $self->error(
$session, $inputString,
'Data backup failed, cannot find data directory \'' . $dataDir . '\'',
);
}
# For convenience, archive to .zip on MS Windows, and to .tgz on Linux
if (! defined $switch) {
if ($^O eq 'MSWin32') {
$ext = 'zip';
} else {
$ext = 'tgz';
}
} elsif ($switch eq '-z') {
$ext = 'zip';
} else {
$ext = 'tgz';
}
# Set the filename, appending the time if required
if (! $axmud::CLIENT->autoBackupAppendFlag) {
$fileName = $axmud::NAME_FILE . '_backup_' . $axmud::CLIENT->localDateString() . '.'
. $ext;
} else {
$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 ($axmud::CLIENT->autoBackupDir && -e $axmud::CLIENT->autoBackupDir) {
$backupPath = $axmud::CLIENT->autoBackupDir;
} else {
$backupPath = $session->mainWin->showFileChooser(
'Backup ' . $axmud::SCRIPT . ' data',
'save',
$fileName,
);
}
if (! $backupPath) {
return $self->complete($session, $standardCmd, 'Data backup not completed');
}
# In case the data directory is large, display an initial message to explain the pause
$session->writeText('Backing up ' . $axmud::SCRIPT . ' data directory...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# 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 = substr($file, length($dataDir));
# 6 is the default compression level
$zipObj->addFileOrDirectory($file, $modFile, 6);
}
}
# Save the .zip file. Successful operation returns 0
if ($zipObj->writeToFileNamed($backupPath)) {
return $self->complete(
$session, $standardCmd,
'Data backup failed (archive error)',
);
} else {
return $self->complete(
$session, $standardCmd,
'Backup of ' . $axmud::SCRIPT . ' data directory saved to ' . $backupPath,
);
}
} 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($file, substr($file, length($dataDir)));
}
}
# Save the .tgz file
if (
! $tarObj->write(
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
return $self->improper($session, $inputString);
}
# Always prompt the user for confirmation
$choice = $session->mainWin->showMsgDialogue(
'Restore data from backup',
'question',
'Are you sure you want to restore data from backup? (This operation will completely'
. ' replace the current ' . $axmud::SCRIPT . ' data directory. In addition, you won\'t'
. ' be able to save any data files until you restart ' . $axmud::SCRIPT
. ', so any data currently in memory will be lost.)',
'yes-no',
);
if (! defined $choice || $choice eq 'no') {
return $self->complete(
$session, $standardCmd,
'Restore data from backup not completed',
);
}
# If a file path was not specified, open a file chooser dialog to decide which file to
# import
if (! $backupPath) {
$backupPath = $session->mainWin->showFileChooser(
'Restore data from backup',
'open',
);
if (! $backupPath) {
return $self->complete(
$session, $standardCmd,
'Restore data from backup not completed',
);
}
}
# ;backupdata only creates archives in .tgz or .zip formats, but this command can recognise
# the usual list of archive types
if (
! ($backupPath =~ m/\.tar$/)
&& ! ($backupPath =~ m/\.tgz$/)
&& ! ($backupPath =~ m/\.gz$/)
&& ! ($backupPath =~ m/\.zip$/)
&& ! ($backupPath =~ m/\.bz2$/)
&& ! ($backupPath =~ m/\.tbz$/)
&& ! ($backupPath =~ m/\.lzma$/)
) {
return $self->error(
$session, $inputString,
'Restore data from backup not completed (you specified something that doesn\'t'
. ' appear to be a compressed archive, e.g. a .zip or .tgz file)',
);
}
# For large files, we need to display an initial message to explain the pause
$session->writeText('Restoring data from backup...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# The old directory is not replaced, but renamed. Cycle through a list of possible names
# until we find one that isn't in use (give up after a reasonable time)
if (! -e $axmud::DATA_DIR . '_OLD') {
$oldDataDir = $axmud::DATA_DIR . '_OLD';
} else {
OUTER: for (my $count = 2; $count <= 1024; $count++) {
$oldDataDir = $axmud::DATA_DIR . '_OLD_' . $count;
if (! -e $oldDataDir) {
last OUTER;
}
}
}
if (! $oldDataDir) {
return $self->error(
$session, $inputString,
'Cannot restore data from backup - unable to find a new name for the existing'
. ' data directory (try deleting a few of them first)',
);
} elsif (-e $axmud::DATA_DIR) {
rename($axmud::DATA_DIR, $oldDataDir);
}
# Build an Archive::Extract object
$extractObj = Archive::Extract->new(archive => $backupPath);
if ($backupPath =~ m/\.zip$/) {
$zipFlag = TRUE;
} else {
$zipFlag = FALSE;
}
if (
! $extractObj
# (A .tar archive contains an 'axmud-data' directory, so we need to extract the archive
# into the parent directory)
|| (! $zipFlag && ! $extractObj->extract(to => $axmud::DATA_DIR . '/..'))
|| ($zipFlag && ! $extractObj->extract(to => $axmud::DATA_DIR))
) {
# The data directory which was just renamed can be returned to its original name, as if
# nothing had happened
rename($oldDataDir, $axmud::DATA_DIR);
return $self->error(
$session, $inputString,
'Cannot restore data from backup (file decompression error)',
);
} else {
# Operation successful. Disable load/save, forcing the user to restart Axmud
$axmud::CLIENT->set_loadConfigFlag(FALSE);
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
if (-f $file) {
$count++;
$file =~ s/$soundDir//;
$session->writeText(' ' . $file);
}
}
# Display footer
if ($count == 1) {
return $self->complete($session, $standardCmd, 'End of list (1 file found)');
} else {
return $self->complete(
$session, $standardCmd,
'End of list (' . $count . ' files found)',
);
}
}
# ;msp -d
} elsif ($dlFlag) {
# Initialise some variables
$urlRegex = $axmud::CLIENT->constUrlRegex;
$tempDir = $axmud::DATA_DIR . '/data/temp/msp-extract';
$targetDir = $axmud::DATA_DIR . '/msp/' . $session->currentWorld->name . '/';
%extHash = $axmud::CLIENT->constSoundFormatHash;
$count = 0;
$errorCount = 0;
# If no URL was specified, prompt the user for one
if (! defined $string) {
$string = $session->mainWin->showEntryDialogue(
'Download MSP sound pack',
'Enter the link for the \'' . $session->currentWorld->longName
. '\' sound pack',
);
if (! defined $string) {
return $self->complete($session, $standardCmd, 'Download operation cancelled');
}
}
# Check the URL is valid
if (! ($string =~ m/$urlRegex/)) {
return $self->error(
$session, $inputString,
'Invalid download link \'' . $string . '\'',
);
}
# Attempt to download the file
$session->writeText('Downloading sound pack \'' . $string . '\'...');
# It might be a long wait, so make sure the message is visible right away
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
$fetchObj = File::Fetch->new(uri => $string);
$dlPath = $fetchObj->fetch(to => $axmud::DATA_DIR . '/data/temp');
if (! $dlPath) {
return $self->error(
$session, $inputString,
'Sound pack download failed; check the link and try again',
);
}
# If it's an archive file, extract it
if (
$dlPath =~ m/\.tar$/
|| $dlPath =~ m/\.tgz$/
|| $dlPath =~ m/\.gz$/
|| $dlPath =~ m/\.zip$/
|| $dlPath =~ m/\.bz2$/
|| $dlPath =~ m/\.tbz$/
|| $dlPath =~ m/\.lzma$/
) {
# Attempt to extract the file
$session->writeText('Sound pack downloaded, extracting...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Build an Archive::Extract object
$extractObj = Archive::Extract->new(archive => $dlPath);
if (! $extractObj) {
return $self->error(
$session, $inputString,
'No files extracted (file decompression error)',
);
}
# Extract the archive
if (! $extractObj->extract(to => $tempDir)) {
return $self->error(
$session, $inputString,
'No files extracted (file decompression error)',
);
}
# Get a list of paths, relative to $tempDir, of all the extracted files
@fileList = @{$extractObj->files}; # e.g. export/tasks.axm
OUTER: foreach my $file (@fileList) {
my $matchFlag;
# Convert all the paths into absolute paths
$file = $axmud::DATA_DIR . '/data/temp/msp-extract/' . $file;
# Any file that ends in a valid sound file extension (one of those specified by
# GA::Client->constSoundFormatHash) should be copied into the current world's
# MSP directory
INNER: foreach my $ext (keys %extHash) {
if ($file =~ m/\.$ext$/) {
$matchFlag = TRUE;
last INNER;
}
}
if ($matchFlag) {
File::Copy::move($file, $targetDir);
$count++;
} else {
# Invalid sound file
unlink $file;
$errorCount++;
}
}
if (! $count) {
return $self->error(
$session, $inputString,
'Didn\'t extract any valid sound files (invalid files: ' . $errorCount
. ')',
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('setdictionary', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['sdy', 'setdict', 'setdictionary'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Sets the current dictionary for this session';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$name, $language,
$check,
) = @_;
# Local variables
my (
$matchFlag, $obj,
@list,
);
# Check for improper arguments
if (! defined $name || defined $check) {
return $self->improper($session, $inputString);
}
# Check there are no 'free' windows open
@list = $axmud::CLIENT->desktopObj->listSessionFreeWins($session, TRUE);
if (@list) {
OUTER: foreach my $winObj (@list) {
if ($winObj->_objClass eq 'Games::Axmud::EditWin::Dict') {
$matchFlag = TRUE;
last OUTER;
}
}
if ($matchFlag) {
return $self->error(
$session, $inputString,
'Can\'t set the current dictionary while there are dictionary \'edit\' windows'
. ' open (try closing them first)',
);
}
}
# If the name is already in use and $language was specified, need to display an error
if ($axmud::CLIENT->ivExists('dictHash', $name) && defined $language) {
return $self->error(
$session, $inputString,
'This command can\'t be used to change the language of the existing dictionary \''
. $name . '\' (try \';setlanguage\')',
);
}
# If the dictionary already exists is already in use, make it current
if ($axmud::CLIENT->ivExists('dictHash', $name)) {
$obj = $axmud::CLIENT->ivShow('dictHash', $name);
$session->set_currentDict($obj);
# The current world profile also stores the current dictionary
$session->currentWorld->ivPoke('dict', $name);
return $self->complete(
$session, $standardCmd,
'The current dictionary has been set to \'' . $name . '\'',
);
}
# Otherwise, check that $name is a valid name
if (! $axmud::CLIENT->nameCheck($name, 16)) {
return $self->error(
$session, $inputString,
'Could not add the dictionary \'' . $name . '\' - invalid name',
);
# If the language was specified, check it's not too long
} elsif ($language && ! $axmud::CLIENT->nameCheck($language, 16)) {
return $self->error(
$session, $inputString,
'Could not add the dictionary \'' . $name . '\' - invalid language \'' . $language
. '\'',
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('deletedictionary', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['ddy', 'deldict', 'deletedict', 'deletedictionary'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Deletes a dictionary';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$name,
$check,
) = @_;
# Local variables
my (
$matchFlag, $obj,
@list,
);
# Check for improper arguments
if (! defined $name || defined $check) {
return $self->improper($session, $inputString);
}
# Check there are no dictionary 'edit' windows open
@list = $axmud::CLIENT->desktopObj->listSessionFreeWins($session, TRUE);
if (@list) {
OUTER: foreach my $winObj (@list) {
if ($winObj->_objClass eq 'Games::Axmud::EditWin::Dict') {
$matchFlag = TRUE;
last OUTER;
}
}
if ($matchFlag) {
return $self->error(
$session, $inputString,
'Can\'t delete a dictionary while there are dictionary \'edit\' window open'
. ' (try closing them first)',
);
}
}
# Check the dictionary exists
if (! $axmud::CLIENT->ivExists('dictHash', $name)) {
return $self->error(
$session, $inputString,
'Could not delete the dictionary \'' . $name . '\' - dictionary doesn\'t exist',
);
} else {
$obj = $axmud::CLIENT->ivShow('dictHash', $name);
}
# Check that the dictionary isn't the current dictionary for this session...
if (defined $session->currentDict && $session->currentDict eq $obj) {
return $self->error(
$session, $inputString,
'Could not delete the dictionary \'' . $name . '\' because it\'s the current'
. ' dictionary for this session',
);
}
# ...or any other session
foreach my $otherSession ($axmud::CLIENT->listSessions()) {
if ($otherSession->currentDict && $otherSession->currentDict eq $obj) {
return $self->error(
$session, $inputString,
'Could not delete the dictionary \'' . $name . '\' because it\'s the current'
. ' dictionary for another session',
);
}
}
# Delete the dictionary
$axmud::CLIENT->del_dict($obj);
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
{ package Games::Axmud::Cmd::SetWorld;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('setworld', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['swo', 'setworld'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Sets the current world profile';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$world, $char,
$check,
) = @_;
# Local variables
my ($result, $statusTask);
# Check for improper arguments
if (! defined $world || defined $check) {
return $self->improper($session, $inputString);
}
# Check there are no 'free' windows open
if ($axmud::CLIENT->desktopObj->listSessionFreeWins($session, TRUE)) {
return $self->error(
$session, $inputString,
'Can\'t set the current world profile while there are edit, preference and wizard'
. ' windows open (try closing them first)',
);
}
# If the world profile already exists, use it
if ($axmud::CLIENT->ivExists('worldProfHash', $world)) {
# Set the current world profile. If <char> was specified, make that the current
# character profile, too
$result = $session->setupProfiles('set_exist', $world, $char);
# Otherwise, create a new world profile, and make it the current one
} else {
# Check that $world is valid
if (! $axmud::CLIENT->nameCheck($world, 16)) {
return $self->error(
$session, $inputString,
'Could not add world profile \'' . $world . '\' - invalid name',
);
}
# Create a world profile and set it as the current world profile. If <char> was
# specified, make that the current character profile, too (creating it, if necessary)
$result = $session->setupProfiles('set_new', $world, $char);
}
# If the Status task's counters are running, reset their values, and turn them off
if ($session->statusTask) {
$session->statusTask->update_profiles();
}
if (! $result) {
return $self->error(
$session, $inputString,
'Could not set \'' . $world . '\' as the current world profile',
);
} else {
return $self->complete(
$session, $standardCmd,
'Set \'' . $world . '\' as the current world profile (don\'t forget to set a'
. ' current character profile with the \';setchar\' command)',
);
}
}
}
{ package Games::Axmud::Cmd::CloneWorld;
use strict;
use warnings;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
{ package Games::Axmud::Cmd::DeleteWorld;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('deleteworld', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['dwo', 'delworld', 'deleteworld'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Deletes a world profile';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$worldName,
$check,
) = @_;
# Local variables
my ($worldObj, $result, $fileObj);
# Check for improper arguments
if (! defined $worldName || defined $check) {
return $self->improper($session, $inputString);
}
# Check there are no 'free' windows open
if ($axmud::CLIENT->desktopObj->listSessionFreeWins($session, TRUE)) {
return $self->error(
$session, $inputString,
'Can\'t delete a world profile while there are edit, preference and wizard windows'
. ' open (try closing them first)',
);
}
# Check that profile exists
if (! $axmud::CLIENT->ivExists('worldProfHash', $worldName)) {
return $self->error(
$session, $inputString,
'Could not delete world profile \'' . $worldName . '\'- profile does not exist',
);
} else {
$worldObj = $axmud::CLIENT->ivShow('worldProfHash', $worldName);
}
# Check it's not the current world profile for this session...
if (defined $session->currentWorld && $session->currentWorld eq $worldObj) {
return $self->error(
$session, $inputString,
'The current world profile can\'t be deleted',
);
# ...or for any other session
} else {
foreach my $otherSession ($axmud::CLIENT->listSessions()) {
if (
defined $otherSession->currentWorld
&& $otherSession->currentWorld eq $worldObj
) {
return $self->error(
$session, $inputString,
'Could not delete world profile \'' . $worldName . '\' - it is in use by'
. ' another session',
);
}
}
}
# Ask the user if they're sure...
$result = $session->mainWin->showMsgDialogue(
'Delete world profile',
'question',
'Are you sure you want to delete the world profile \'' . $worldName . '\'? (Doing so'
. ' will remove it from memory AND destroy its data files)',
'yes-no',
);
if ($result ne 'yes') {
return $self->complete($session, $standardCmd, 'World profile deletion cancelled');
}
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('restoreworld', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['rwo', 'restoreworld'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Restores pre-configured worlds';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$arg,
$check,
) = @_;
# Local variables
my (
$count, $msg, $response, $successCount,
@worldList, @existList, @missingList, @successList, @newWorldList,
%fileObjHash, %worldHash, %archivePathHash, %newHash,
);
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Check there are no 'free' windows open
if ($axmud::CLIENT->desktopObj->listSessionFreeWins($session, TRUE)) {
return $self->error(
$session, $inputString,
'Can\'t restore a world profile while there are edit, preference and wizard windows'
. ' open (try closing them first)',
);
}
# Check that all sessions have their ->status set to 'disconnected' (already disconnected
# from the world), or running in 'connect offline' mode
$count = 0;
foreach my $otherSession ($axmud::CLIENT->listSessions()) {
if ($otherSession->status ne 'disconnected' && $otherSession->status ne 'offline') {
$count++;
}
}
if ($count) {
$msg = 'To avoid losing data, the restore pre-configured worlds operation can only be'
. ' started when all sessions are disconnected (or running in \'offline\''
. ' mode); there ';
if ($count == 1) {
$msg .= 'is 1 session';
} else {
$msg .= 'are ' . $count . ' sessions';
}
return $self->error(
$session, $inputString,
$msg . ' still connected to a world',
);
}
# If there are any unsaved files, show a warning before continuing. First, count the number
# of unsaved files. Store each file object found in a hash, so that we don't count
# duplicates
$count = 0;
foreach my $fileObj ($axmud::CLIENT->ivValues('fileObjHash')) {
if (! exists $fileObjHash{$fileObj}) {
$fileObjHash{$fileObj} = undef;
if ($fileObj->modifyFlag) {
# Unsaved file
$count++;
}
}
}
foreach my $otherSession ($axmud::CLIENT->listSessions()) {
foreach my $fileObj ($otherSession->ivValues('sessionFileObjHash')) {
if (! exists $fileObjHash{$fileObj}) {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
{ package Games::Axmud::Cmd::SetCustomProfile;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('setcustomprofile', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['scp', 'setcustom', 'setcustomprof', 'setcustomprofile'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Sets a current custom profile';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$profile, $templ,
$check,
) = @_;
# Local variables
my ($profObj, $templObj, $oldObj, $currentObj, $fixedFlag);
# Check for improper arguments
if (! defined $profile || defined $check) {
return $self->improper($session, $inputString);
}
# Check there are no 'free' windows open
if ($axmud::CLIENT->desktopObj->listSessionFreeWins($session, TRUE)) {
return $self->error(
$session, $inputString,
'Can\'t set a current profile while there are edit, preference and wizard windows'
. ' open (try closing them first)',
);
}
# The user can only omit <templ> if the custom profile <name> already exists
if (! $templ) {
if (! $session->ivExists('profHash', $profile)) {
return $self->error(
$session, $inputString,
'Could not set custom profile \'' . $profile . '\' - profile does not yet exist'
. ' (try \';setcustomprofile <name> <templ>\')',
);
} else {
$profObj = $session->ivShow('profHash', $profile);
$templ = $profObj->category;
}
}
# Check that <templ> isn't one of the standard profile categories ('world', 'guild',
# 'race', 'char'), which don't exist as templates
if (defined $axmud::CLIENT->ivFind('constProfPriorityList', $templ)) {
return $self->error(
$session, $inputString,
'Cannot set custom profiles for that category - \'' . $templ
. '\' is a standard profile category, not a profile template',
);
}
# Check that <templ> exists
if (! $session->ivExists('templateHash', $templ)) {
return $self->error(
$session, $inputString,
'Could not use ' . $templ . ' profile template - profile template doesn\'t exist',
);
} else {
$templObj = $session->ivShow('templateHash', $templ);
}
# If the profile already exists, check it isn't already a current profile
if ($session->ivExists('currentProfHash', $templ)) {
$currentObj = $session->ivShow('currentProfHash', $templ);
if ($currentObj->name eq $profile) {
# Error message depends on whether it's the right kind of profile
if ($currentObj->category eq $templ) {
return $self->error(
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('unsetcustomprofile', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = [
'ucp',
'unsetcustom',
'unsetcustomprof',
'unsetcustomprofile',
];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Unsets a current custom profile';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$profile,
$check,
) = @_;
# Local variables
my $profObj;
# Check for improper arguments
if (! defined $profile || defined $check) {
return $self->improper($session, $inputString);
}
# Check there are no 'free' windows open
if ($axmud::CLIENT->desktopObj->listSessionFreeWins($session, TRUE)) {
return $self->error(
$session, $inputString,
'Can\'t unset a current profile while there are edit, preference and wizard windows'
. ' open (try closing them first)',
);
}
# Check that the profile exists
if (! $session->ivExists('profHash', $profile)) {
return $self->error(
$session, $inputString,
'The profile \'' . $profile . '\' doesn\'t exist',
);
} else {
$profObj = $session->ivShow('profHash', $profile);
}
# Check it's a current custom profile
if (! $session->ivExists('templateHash', $profObj->category)) {
return $self->error(
$session, $inputString,
'The profile \'' . $profile . '\' isn\'t a custom profile',
);
} elsif (
! $session->ivExists('currentProfHash', $profObj->category)
|| $session->ivShow('currentProfHash', $profObj->category) ne $profObj
) {
return $self->error(
$session, $inputString,
'The profile \'' . $profile . '\' isn\'t a current profile',
);
}
# If there's a current character, inform it it's lost a custom profile
if ($session->currentChar) {
$session->currentChar->ivDelete('customProfHash', $profile);
}
# Remove this profile's interfaces
$session->resetProfileInterfaces($profObj->name);
# Unset any cages for this profile as current cages
$session->unsetCurrentCages($profile, $profObj->category);
# Unset the profile as a current defintitions
$session->del_currentProf($profObj->category);
# If the Status task's counters are running, reset their values, and turn them off
if ($session->statusTask) {
$session->statusTask->update_profiles();
}
return $self->complete(
$session, $standardCmd,
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('deletecustomprofile', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = [
'dcp',
'delcustom',
'delcustomprof',
'deletecustomprofile',
];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Deletes a custom profile';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$profile,
$check,
) = @_;
# Local variables
my ($profObj, $category);
# Check for improper arguments
if (! defined $profile || defined $check) {
return $self->improper($session, $inputString);
}
# Check there are no 'free' windows open
if ($axmud::CLIENT->desktopObj->listSessionFreeWins($session, TRUE)) {
return $self->error(
$session, $inputString,
'Can\'t delete a profile while there are edit, preference and wizard windows'
. ' open (try closing them first)',
);
}
# Check that the original profile exists (without which, we can't find its
# ->category)
if (! $session->ivExists('profHash', $profile)) {
return $self->error(
$session, $inputString,
'Could not delete the custom profile \'' . $profile . '\' - the profile doesn\'t'
. ' exist',
);
} else {
$profObj = $session->ivShow('profHash', $profile);
$category = $profObj->category;
}
# Check it's a custom profile
if (! $session->ivExists('templateHash', $category)) {
return $self->error(
$session, $inputString,
'Could not delete the custom profile \'' . $profile . '\' - the profile is not a'
. ' custom profile',
);
}
# Delete the profile
return $self->deleteProfile($session, $inputString, $standardCmd, $profile, $category);
}
}
{ package Games::Axmud::Cmd::ListCustomProfile;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# Check each directory in the GA::Client's list, looking for a file matching $scriptName
# (but first check in the standard directory)
$standardPath = $axmud::DATA_DIR . '/scripts/' . $scriptName . '.bas';
if (-e $standardPath) {
$path = $standardPath;
} else {
OUTER: foreach my $dir ($axmud::CLIENT->scriptDirList) {
my $thisPath = $dir . '/' . $scriptName . '.bas';
if (-e $thisPath) {
$path = $thisPath;
last OUTER;
}
}
}
if (! $path) {
return $self->error(
$session, $inputString,
$axmud::BASIC_NAME . ' script \'' . $scriptName . '\' not found',
);
}
}
# Load the script into the raw script object
if (! $rawScriptObj->loadFile($path)) {
return $self->error(
$session, $inputString,
'Can\'t load the ' . $axmud::BASIC_NAME . ' script \'' . $path . '\'',
);
}
# Create a script object, which processes the raw script, removing extraneous whitespace,
# empty lines, comments, etc
$scriptObj = Language::Axbasic::Script->new($session, $rawScriptObj);
if (! defined $scriptObj) {
return $self->error(
$session, $inputString,
'General error starting the ' . $axmud::BASIC_NAME . ' script \'' . $scriptName
. '\' (can\'t create a script object)',
);
}
# Execute the script
if (! $scriptObj->implement()) {
return $self->error(
$session, $inputString,
'Execution of the ' . $axmud::BASIC_NAME . ' script \'' . $scriptName . '\' failed',
);
}
# Sensitise/desensitise menu bar/toolbar items, depending on current conditions
$axmud::CLIENT->desktopObj->restrictWidgets();
if ($scriptObj->scriptStatus eq 'paused') {
return $self->complete(
$session, $standardCmd,
'Execution of the ' . $axmud::BASIC_NAME . ' script \'' . $scriptName
. '\' started',
);
} else {
# No error message required - user has already seen 'AXBASIC: Execution complete'
return 1;
}
}
}
{ package Games::Axmud::Cmd::RunScriptTask;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('runscripttask', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['rst', 'runscripttask'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Runs ' . $axmud::BASIC_ARTICLE . ' script as a task';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('useworkspace', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['uws', 'usews', 'useworkspace'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Makes a workspace available for ' . $axmud::SCRIPT . ' to use';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args,
) = @_;
# Local variables
my (
$switch, $zonemap, $name, $useWorkspace, $workspaceObj,
@workspaceList,
);
# Extract switches
($switch, $zonemap, @args) = $self->extract('-z', 1, @args);
# Get the remaining argument (if any)
$name = shift @args;
# There should be no further arguments
if (@args) {
return $self->improper($session, $inputString);
}
# In certain circumstances, new workspaces can't be used
if (! $axmud::CLIENT->desktopObj->newWorkspaceFlag) {
return $self->error(
$session, $inputString,
'Unable to use any new workspaces (try restarting ' . $axmud::SCRIPT . ')',
);
}
# If a zonemap was specified, check it exists
if (defined $zonemap && ! $axmud::CLIENT->ivExists('zonemapHash', $zonemap)) {
return $self->error(
$session, $inputString,
'Zonemap \'' . $zonemap . '\' doesn\'t exist',
);
}
# Get a list of Gnome2::Workspace objects (which might conceivably be different to the
# list found on the original call to GA::Obj::Desktop->detectWorkspaces)
@workspaceList = $axmud::CLIENT->desktopObj->detectWorkspaces();
# ;uws
if (! defined $name) {
# Find the first available workspace that's not in use
OUTER: foreach my $workspace (@workspaceList) {
INNER: foreach $workspaceObj (
$axmud::CLIENT->desktopObj->ivValues('workspaceHash')
) {
if ($workspaceObj->systemNum eq $workspace) {
next OUTER;
}
}
# This workspace is not in use, but is available
$useWorkspace = $workspace;
last OUTER;
}
if (! $useWorkspace) {
return $self->error(
$session, $inputString,
'There are no more workspaces available for ' . $axmud::SCRIPT . ' to use',
);
}
# ;uws <number>
} else {
OUTER: foreach my $workspace (@workspaceList) {
if ($workspace eq $name) {
$useWorkspace = $workspace;
last OUTER;
}
}
if (! $useWorkspace) {
return $self->error(
$session, $inputString,
'System workspace \'' . $name . '\' not found',
);
}
}
# Add a workspace object (GA::Obj::Workspace) for this workspace
$workspaceObj = $axmud::CLIENT->desktopObj->useWorkspace($useWorkspace, $zonemap);
if (! $workspaceObj) {
return $self->error(
$session, $inputString,
'General error adding the system workspace \'' . $name . '\'',
);
} else {
return $self->complete(
$session, $standardCmd,
'Workspace #' . $useWorkspace->get_number() . ' \'' . $useWorkspace->get_name()
. '\' made available for use (' . $axmud::SCRIPT . ' workspace object #'
. $workspaceObj->number . ')',
);
}
}
}
{ package Games::Axmud::Cmd::EditWorkspace;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('editworkspace', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['ews', 'editws', 'editworkspace'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Opens an \'edit\' window for a workspace object';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number,
$check,
) = @_;
# Local variables
my $obj;
# Check for improper arguments
if (! defined $number || defined $check) {
return $self->improper($session, $inputString);
}
# Check the workspace object exists
$obj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $number);
if (! $obj) {
return $self->error(
$session, $inputString,
'Could not edit workspace object #' . $number . ' - object does not exist',
);
}
# Open an 'edit' window for the workspace object
if (
! $session->mainWin->createFreeWin(
'Games::Axmud::EditWin::Workspace',
$session->mainWin,
$session,
'Edit workspace object #' . $number,
$obj,
FALSE, # Not temporary
)
) {
return $self->error(
$session, $inputString,
'Could not edit workspace object #' . $number,
);
} else {
return $self->complete(
$session, $standardCmd,
'Opened \'edit\' window for workspace object #' . $number,
);
}
}
}
{ package Games::Axmud::Cmd::RemoveWorkspace;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('removeworkspace', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['rws', 'removews', 'removeworkspace'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Makes a workspace unavailable for ' . $axmud::SCRIPT . ' use';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$num,
$check,
) = @_;
# Local variables
my ($workspaceObj, $gridCount, $mainCount, $msg, $choice);
# Check for improper arguments
if (! defined $num || defined $check) {
return $self->improper($session, $inputString);
}
# Check the workspace object exists
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $num);
if (! $workspaceObj) {
return $self->error(
$session, $inputString,
'Workspace #' . $num . ' is not currently in use (try \';listworkspace\')',
);
}
# The default workspace (the one in which Axmud opened) can't be removed
if ($num == 0) {
return $self->error(
$session, $inputString,
'The default workspace #0 can\'t be removed',
);
}
# Count the number of 'grid' and 'main' windows that will close
$gridCount = 0;
$mainCount = 0;
foreach my $gridObj ($workspaceObj->ivValues('gridHash')) {
foreach my $winObj ($gridObj->ivValues('gridWinHash')) {
$gridCount++;
if ($winObj->winType eq 'main') {
$mainCount++;
}
}
}
if ($mainCount) {
# Don't close a workspace with a shared 'main' window
if ($axmud::CLIENT->shareMainWinFlag) {
return $self->error(
$session, $inputString,
'Cannot remove workspace #' . $num . ' because it contains a shared \'main\''
. ' window',
);
} else {
$msg = 'Do you really want to remove workspace #' . $num . '? (It contains ';
if ($mainCount == 1) {
$msg .= ' \'main\' window';
} else {
$msg .= $mainCount . ' \'main\' windows';
}
$msg .= ', which will close too)';
$choice = $session->mainWin->showMsgDialogue(
'Remove workspace',
'question',
$msg,
'yes-no',
);
if ($choice ne 'yes') {
return $self->complete(
$session, $standardCmd,
'Remove workspace operation cancelled',
);
}
}
}
# Remove the workspace
if (! $axmud::CLIENT->desktopObj->del_workspace($workspaceObj)) {
return $self->error(
$session, $inputString,
'General error removing workspace #' . $num,
);
} else {
return $self->complete(
$session, $standardCmd,
'Workspace #' . $num . ' made unavailable for use (\'grid\' windows closed: '
. $gridCount . ')',
);
}
}
}
{ package Games::Axmud::Cmd::ListWorkspace;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('listworkspace', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['lws', 'listws', 'listworkspace'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Lists all workspaces';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
) = @_;
# Local variables
my (
$msg,
@workspaceList,
);
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Display header
$session->writeText('Workspace status');
$msg = ' ' . $axmud::SCRIPT . ' is capable of creating workspace grids: ';
if ($axmud::CLIENT->desktopObj->gridPermitFlag) {
$msg .= 'yes';
} else {
$msg .= 'no';
}
$session->writeText($msg);
$msg = ' Workspace grids are activated in general: ';
if ($axmud::CLIENT->activateGridFlag) {
$msg .= 'yes';
} else {
$msg .= 'no';
}
$session->writeText($msg);
$session->writeText('List of workspaces currently used by ' . $axmud::SCRIPT);
# Display list
foreach my $workspaceObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('workspaceHash'))
) {
$session->writeText(
' Workspace #' . $workspaceObj->number . ' (system: #'
. $workspaceObj->systemNum . '\')',
);
$session->writeText(
' Size: width ' . $workspaceObj->currentWidth . ' height '
. $workspaceObj->currentHeight,
);
$session->writeText(
' Panel sizes: left ' . $workspaceObj->panelLeftSize
. ' right ' . $workspaceObj->panelRightSize . ' top ' . $workspaceObj->panelTopSize
. ' bottom ' . $workspaceObj->panelBottomSize,
);
$session->writeText(
' Window controls sizes: left ' . $workspaceObj->controlsLeftSize
. ' right ' . $workspaceObj->controlsRightSize . ' top '
. $workspaceObj->controlsTopSize . ' bottom ' . $workspaceObj->controlsBottomSize,
);
if (! $workspaceObj->gridEnableFlag) {
$session->writeText(' Workspace grids enabled: no');
} else {
$session->writeText(' Workspace grids enabled: yes');
if (! $workspaceObj->gridHash) {
$session->writeText(' (no workspace grids found)');
} else {
$session->writeText(' Num Session Zonemap Zones Windows');
foreach my $gridObj (
sort {$a->number <=> $b->number} ($workspaceObj->ivValues('gridHash'))
) {
my $string;
if ($gridObj->owner) {
$string = $gridObj->owner->number;
} else {
$string = '(shared)';
}
$session->writeText(
' ' . sprintf(
'%-4.4s %-8.8s %-16.16s %-6.6s',
$gridObj->number,
$string,
$gridObj->zonemap,
$gridObj->ivPairs('zoneHash'),
) . $gridObj->ivPairs('gridWinHash'),
);
}
}
$session->writeText(
' Workspace grids found: ' . $workspaceObj->ivPairs('gridHash')
. ', default zonemap: ' . $workspaceObj->defaultZonemap,
);
}
}
# Get a list of unused system workspace numbers (which might conceivably be different to
# the list found on the original call to GA::Obj::Desktop->detectWorkspaces)
@workspaceList = $axmud::CLIENT->desktopObj->detectUnusedWorkspaces();
if (@workspaceList) {
$session->writeText('List of unused (but available) workspaces');
foreach my $workspace (@workspaceList) {
$session->writeText(' System #' . $workspace);
}
}
# Display footer
return $self->complete(
$session, $standardCmd,
'End of list (workspaces used: '
. $axmud::CLIENT->desktopObj->ivPairs('workspaceHash')
. ', not used but available: ' . (scalar @workspaceList) . ')',
);
}
}
{ package Games::Axmud::Cmd::SetWorkspaceDirection;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('setworkspacedirection', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['swd', 'setwsdir', 'setworkspacedirection'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Sets the way in which new workspaces are used';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch,
$check,
) = @_;
# Local variables
my $dir;
# Check for improper arguments
if (defined $check) {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('testwindowcontrols', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['twc', 'testwc', 'testcontrols', 'testwindowcontrols'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Finds the size of window controls';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$num,
$check,
) = @_;
# Local variables
my (
$workspaceObj,
@sizeList, @sideList,
);
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Decide which workspace should perform the test
if (! defined $num) {
# If none specified, use the default workspace
$num = 0;
}
# Check the specified workspace exists
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $num);
if (! $workspaceObj) {
return $self->error($session, $inputString, 'Workspace #' . $num . ' doesn\'t exist');
}
# Perform the test
@sizeList = $workspaceObj->findWinControlSize();
if (! @sizeList) {
return $self->error(
$session, $inputString,
'Window controls test on workspace #' . $num . ' failed',
);
} else {
# Show header
$session->writeText('Window controls test on workspace #' . $num . ' succeeded');
$session->writeText(' Side Size detected Custom size Using size');
# Show list
@sideList = ('left', 'right', 'top', 'bottom');
do {
my ($size, $side, $iv, $iv2, $string);
$size = shift @sizeList;
$side = shift @sideList;
$iv = 'customControls' . ucfirst($side) . 'Size'; # e.g. ->customControlsLeftSize
$iv2 = 'controls' . ucfirst($side) . 'Size'; # e.g. ->controlsLeftSize
if (defined $axmud::CLIENT->$iv) {
$string = $axmud::CLIENT->$iv;
} else {
$string = '(not set)';
}
$session->writeText(
' ' . sprintf(
'%-8.8s %-16.16s %-16.16s %-16.16s',
$side,
$size,
$string,
$workspaceObj->$iv2,
),
);
} until (! @sizeList);
# Show footer
return $self->complete($session, $standardCmd, 'End of test');
}
}
}
{ package Games::Axmud::Cmd::SetWindowControls;
use strict;
use warnings;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
) = @_;
# Local variables
my @list;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Display header
$session->writeText('List of window controls sizes');
$session->writeText(' Custom size Default size');
# Display list
@list = ('left', 'right', 'top', 'bottom');
foreach my $item (@list) {
my ($customIV, $customString, $constIV, $constString);
$customIV = 'customControls' . ucfirst($item) . 'Size';
if (defined $axmud::CLIENT->$customIV) {
$customString = $axmud::CLIENT->$customIV;
} else {
$customString = 'not set';
}
$constIV = 'constControls' . ucfirst($item) . 'Size';
if (defined $axmud::CLIENT->$constIV) {
$constString = $axmud::CLIENT->$constIV;
} else {
$constString = 'not set';
}
$session->writeText(
' ' . sprintf(
'%-8.8s %-16.16s %-16.16s',
ucfirst($item),
$customString,
$constString,
),
);
}
# Display header
$session->writeText('List of window controls sizes in workspaces');
$session->writeText(' Wkspace Left Right Top Bottom');
# Display list
foreach my $workspaceObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('workspaceHash'))
) {
$session->writeText(
' ' . sprintf(
'%-4.4s %-5.5s %-5.5s %-5.5s %-5.5s',
$workspaceObj->number,
$workspaceObj->controlsLeftSize,
$workspaceObj->controlsRightSize,
$workspaceObj->controlsTopSize,
$workspaceObj->controlsBottomSize,
),
);
}
# Display footer
return $self->complete($session, $standardCmd, 'End of lists');
}
}
{ package Games::Axmud::Cmd::TestPanel;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('testpanel', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['tpn', 'testpn', 'testpanel'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Detects sizes of workspace panels (taskbars)';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$num,
$check,
) = @_;
# Local variables
my (
$workspaceObj,
@sizeList, @sideList,
);
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Decide which workspace should perform the test
if (! defined $num) {
# If none specified, use the default workspace
$num = 0;
}
# Check the specified workspace exists
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $num);
if (! $workspaceObj) {
return $self->error($session, $inputString, 'Workspace #' . $num . ' doesn\'t exist');
}
# Perform the test
@sizeList = $workspaceObj->findPanelSize();
if (! @sizeList) {
return $self->error(
$session, $inputString,
'Panel test on workspace #' . $num . ' failed',,
);
} else {
# Show header
$session->writeText('Panel test on workspace #' . $num . ' succeeded');
$session->writeText(' Panel Size detected Custom size Using size');
# Show list
@sideList = ('left', 'right', 'top', 'bottom');
do {
my ($size, $side, $iv, $iv2, $string);
$size = shift @sizeList;
$side = shift @sideList;
$iv = 'customPanel' . ucfirst($side) . 'Size'; # e.g. ->customPanelLeftSize
$iv2 = 'panel' . ucfirst($side) . 'Size'; # e.g. ->panelLeftSize
if (defined $axmud::CLIENT->$iv) {
$string = $axmud::CLIENT->$iv;
} else {
$string = '(not set)';
}
$session->writeText(
' ' . sprintf(
'%-8.8s %-16.16s %-16.16s %-16.16s',
$side,
$size,
$string,
$workspaceObj->$iv2,
),
);
} until (! @sizeList);
# Show footer
return $self->complete($session, $standardCmd, 'End of test');
}
}
}
{ package Games::Axmud::Cmd::SetPanel;
use strict;
use warnings;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
) = @_;
# Local variables
my @list;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Display header
$session->writeText('List of workspace panel sizes');
$session->writeText(' Custom size Default size');
# Display list
@list = ('left', 'right', 'top', 'bottom');
foreach my $item (@list) {
my ($customIV, $customString, $constIV, $constString);
$customIV = 'customPanel' . ucfirst($item) . 'Size';
if (defined $axmud::CLIENT->$customIV) {
$customString = $axmud::CLIENT->$customIV;
} else {
$customString = 'not set';
}
$constIV = 'constPanel' . ucfirst($item) . 'Size';
if (defined $axmud::CLIENT->$constIV) {
$constString = $axmud::CLIENT->$constIV;
} else {
$constString = 'not set';
}
$session->writeText(
' ' . sprintf(
'%-8.8s %-16.16s %-16.16s',
ucfirst($item),
$customString,
$constString,
),
);
}
# Display header
$session->writeText('List of panel sizes in workspaces');
$session->writeText(' Wkspace Left Right Top Bottom');
# Display list
foreach my $workspaceObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('workspaceHash'))
) {
$session->writeText(
' ' . sprintf(
'%-4.4s %-5.5s %-5.5s %-5.5s %-5.5s',
$workspaceObj->number,
$workspaceObj->panelLeftSize,
$workspaceObj->panelRightSize,
$workspaceObj->panelTopSize,
$workspaceObj->panelBottomSize,
),
);
}
# Display footer
return $self->complete($session, $standardCmd, 'End of list');
}
}
# Winmaps and winzones
{ package Games::Axmud::Cmd::AddWinmap;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('addwinmap', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['awm', 'addwm', 'addwinmap'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Adds a new winmap';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('activategrid', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['agr', 'actgrid', 'activategrid'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Activates (turns on) workspace grids';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args,
) = @_;
# Local variables
my ($switch, $zonemap, $num, $zonemapObj, $workspaceObj);
# Extract switches
($switch, $zonemap, @args) = $self->extract('-z', 1, @args);
# Get the remaining arguments
$num = shift @args;
# There should be no further arguments
if (@args) {
return $self->improper($session, $inputString);
}
# Are workspace grids available at all?
if (! $axmud::CLIENT->desktopObj->gridPermitFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are not available at all on this system',
);
}
# If a zonemap was specified, perform some checks
if ($zonemap) {
$zonemapObj = $axmud::CLIENT->ivShow('zonemapHash', $zonemap);
if (! $zonemapObj) {
return $self->error(
$session, $inputString,
'The zonemap \'' . $zonemap . '\' doesn\'t exist',
);
} elsif ($zonemapObj->tempFlag) {
return $self->error(
$session, $inputString,
'Workspace grids can\'t be activated with a temporary zonemap',
);
} elsif (! $zonemapObj->modelHash) {
return $self->error(
$session, $inputString,
'Workspace grids can\'t be activated with the zonemap \'' . $zonemap
. '\' because it contains no zone models',
);
}
}
# ;awg
# ;awg -z <zonemap>
if (! defined $num) {
# Are workspace grids already activated in general?
if ($axmud::CLIENT->activateGridFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are already activated in general',
);
}
# Activate workspace grids in general
if (! $axmud::CLIENT->desktopObj->activateWorkspaceGrids($zonemap)) {
return $self->error(
$session, $inputString,
'General error activating workspace grids',
);
} else {
return $self->complete(
$session, $standardCmd,
'Workspace grids have been activated generally',
);
}
# ;awg <num>
# ;awg <num> -z <zonemap>
# ;awg -z <zonemap> <num>
} else {
# Are workspace grids disactivated in general?
if (! $axmud::CLIENT->activateGridFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are disactivated in general',
);
}
# Are workspaces enabled on the specified workspace?
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $num);
if (! $workspaceObj) {
return $self->error(
$session, $inputString,
'Workspace #' . $num . ' doesn\'t exist',
);
} elsif ($workspaceObj->gridEnableFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are already activated on workspace #' . $num,
);
}
# Enable workspace grids on the workspace
if (! $workspaceObj->enableWorkspaceGrids($zonemap)) {
return $self->error(
$session, $inputString,
'General error activating workspace grids on workspace #' . $num,
);
} else {
return $self->complete(
$session, $standardCmd,
'Workspace grids activated on workspace #' . $num,
);
}
}
}
}
{ package Games::Axmud::Cmd::DisactivateGrid;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('disactivategrid', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['dgr', 'disactgrid', 'disactivategrid'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Disactivates (turns off) workspace grids';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$num,
$check,
) = @_;
# Local variables
my $workspaceObj;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Are workspace grids available at all?
if (! $axmud::CLIENT->desktopObj->gridPermitFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are not available at all on this system',
);
}
# ;dwg
if (! defined $num) {
# Are workspace grids already disactivated in general?
if (! $axmud::CLIENT->activateGridFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are already disactivated in general',
);
}
# Disactivate workspace grids in general
if (! $axmud::CLIENT->desktopObj->disactivateWorkspaceGrids()) {
return $self->error(
$session, $inputString,
'General error disactivating workspace grids',
);
} else {
return $self->complete(
$session, $standardCmd,
'Workspace grids have been disactivated generally',
);
}
# ;dwg <num>
} else {
# Are workspace grids disactivated in general?
if (! $axmud::CLIENT->activateGridFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are disactivated in general',
);
}
# Are workspaces disabled on the specified workspace?
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $num);
if (! $workspaceObj) {
return $self->error(
$session, $inputString,
'Workspace #' . $num . ' doesn\'t exist',
);
} elsif (! $workspaceObj->gridEnableFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are already disactivated on workspace #' . $num,
);
}
# Disable workspace grids on the workspace
if (! $workspaceObj->disableWorkspaceGrids()) {
return $self->error(
$session, $inputString,
'General error disactivating workspace grids on workspace #' . $num,
);
} else {
return $self->complete(
$session, $standardCmd,
'Workspace grids disactivated on workspace #' . $num,
);
}
}
}
}
{ package Games::Axmud::Cmd::SetGrid;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
);
} else {
$axmud::CLIENT->set_gridAdjustmentFlag($testFlag);
$resetMsg = 'Workspace grid adjustment flag set to \'' . $string . '\'',
}
# ;sgr -e <flag>
} elsif ($switch eq '-e') {
if ($axmud::CLIENT->gridEdgeCorrectionFlag eq $testFlag) {
return $self->complete(
$session, $standardCmd,
'Workspace grid edge correction flag was already set to \'' . $string
. '\'',
);
} else {
$axmud::CLIENT->set_gridEdgeCorrectionFlag($testFlag);
$resetMsg = 'Workspace grid edge correction flag set to \'' . $string . '\'',
}
# ;sgr -r <flag>
} elsif ($switch eq '-r') {
if ($axmud::CLIENT->gridReshuffleFlag eq $testFlag) {
return $self->complete(
$session, $standardCmd,
'Workspace grid window reshuffle flag was already set to \'' . $string
. '\'',
);
} else {
$axmud::CLIENT->set_gridReshuffleFlag($testFlag);
$resetMsg = 'Workspace grid window reshuffle flag set to \'' . $string . '\'',
}
# ;sgr -i <flag>
} else {
if ($axmud::CLIENT->gridInvisWinFlag eq $testFlag) {
return $self->complete(
$session, $standardCmd,
'Workspace grid invisible window flag was already set to \'' . $string
. '\'',
);
} else {
$axmud::CLIENT->set_gridInvisWinFlag($testFlag);
$resetMsg = 'Workspace grid invisible window flag set to \'' . $string . '\'',
}
}
}
# If this function hasn't yet used $self->error or $self->complete, then all workspace grids
# must be reset
foreach my $workspaceObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('workspaceHash'))
) {
foreach my $gridObj (
sort {$a->number <=> $b->number} ($workspaceObj->ivValues('gridHash'))
) {
$gridObj->applyZonemap();
}
}
return $self->complete($session, $standardCmd, $resetMsg);
}
}
{ package Games::Axmud::Cmd::ResetGrid;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('resetgrid', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['rgr', 'resetgrid'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Resets workspace grids';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args,
) = @_;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
($switch, @args) = $self->extract('-w', 0, @args);
if (defined $switch) {
$workspaceFlag = TRUE;
}
# Get the remaining arguments
if ($sessionFlag) {
$zonemap = shift @args;
} else {
$num = shift @args;
$zonemap = shift @args;
}
# There should be no further arguments
if (
(! $sessionFlag && ! $workspaceFlag && ! defined $num)
|| ($workspaceFlag && ! defined $num)
|| @args
) {
return $self->improper($session, $inputString);
}
# If a zonemap was specified, check it exists, is not temporary and contains some zone
# models
if ($zonemap) {
$zonemapObj = $axmud::CLIENT->ivShow('zonemapHash', $zonemap);
if (! $zonemapObj) {
return $self->error(
$session, $inputString,
'The zonemap \'' . $zonemap . '\' doesn\'t exist',
);
} elsif ($zonemapObj->tempFlag) {
return $self->error(
$session, $inputString,
'Can\'t reset workspace grid(s) using a temporary zonemap',
);
} elsif (! $zonemapObj->modelHash) {
return $self->error(
$session, $inputString,
'Can\'t reset the workspace grid(s) with the zonemap \'' . $zonemap
. '\' because it contains no zone models',
);
}
}
# ;rgr <num>
# ;rgr <num> <zonemap>
if (! $sessionFlag && ! $workspaceFlag) {
# Check the specified workspace grid objects exists
$gridObj = $axmud::CLIENT->desktopObj->ivShow('gridHash', $num);
if (! $gridObj) {
return $self->error(
$session, $inputString,
'Workspace grid #' . $num . ' doesn\'t exist',
);
}
# Only one workspace grid to reset
push (@list, $gridObj);
# ;rgr -s
# ;rgr -s <zonemap>
} elsif ($sessionFlag) {
# All workspace grid objects controlled by this session should be reset
foreach my $thisGridObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('gridHash'))
) {
if ($thisGridObj->owner && $thisGridObj->owner eq $session) {
push (@list, $thisGridObj);
}
}
# ;rgr -w <num>
# ;rgr -w <num> <zonemap>
} elsif ($workspaceFlag) {
# Check the specified workspace object exists
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $num);
if (! $workspaceObj) {
return $self->error(
$session, $inputString,
'Workspace #' . $num . ' doesn\'t exist',
);
}
# Set the workspace's new default zonemap
if ($zonemapObj) {
$workspaceObj->set_defaultZonemap($zonemapObj);
}
# All workspace grid objects on this workspace should be reset
push (@list, sort {$a->number <=> $b->number} ($workspaceObj->ivValues('gridHash')));
}
if (! @list) {
return $self->error(
$session, $inputString,
'No matching workspace grid(s) found',
);
}
# If a zonemap was specified, apply it to all affected workspace grid objects (otherwise use
# the existing zonemap)
$count = 0;
$errorCount = 0;
OUTER: foreach my $thisGridObj (@list) {
my $thisWorkspaceObj = $thisGridObj->workspaceObj;
if (! $thisGridObj->applyZonemap($zonemapObj)) {
$errorCount++;
# There are two types of error in the call to ->applyZonemap, one of which disables
# workspace grids on the workspace. Must halt if that happens
if (! $thisWorkspaceObj->gridEnableFlag) {
$haltNumber = $thisWorkspaceObj->number;
last OUTER;
}
} else {
$count++;
}
}
if (defined $haltNumber) {
return $self->error(
$session, $inputString,
'Could not reset specified workspace grids; in addition, grids have been'
. ' disabled in workspace #' . $haltNumber,
);
} elsif (! $count) {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
{ package Games::Axmud::Cmd::EditGrid;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('editgrid', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['egr', 'editgrid'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Opens an \'edit\' window for a workspace grid';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number,
$check,
) = @_;
# Local variables
my $obj;
# Check for improper arguments
if (! defined $number || defined $check) {
return $self->improper($session, $inputString);
}
# Check the workspace grid object exists
$obj = $axmud::CLIENT->desktopObj->ivShow('gridHash', $number);
if (! $obj) {
return $self->error(
$session, $inputString,
'Could not edit workspace grid #' . $number . ' - object does not exist',
);
}
# Open an 'edit' window for the workspace grid
if (
! $session->mainWin->createFreeWin(
'Games::Axmud::EditWin::WorkspaceGrid',
$session->mainWin,
$session,
'Edit workspace grid #' . $number,
$obj,
FALSE, # Not temporary
)
) {
return $self->error(
$session, $inputString,
'Could not edit workspace grid #' . $number,
);
} else {
return $self->complete(
$session, $standardCmd,
'Opened \'edit\' window for workspace grid #' . $number,
);
}
}
}
{ package Games::Axmud::Cmd::ListGrid;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('listgrid', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['lgr', 'listgrid'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Lists workspace grids';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch, $num,
$check,
) = @_;
# Local variables
my (
$workspaceObj, $thisSession, $string,
@list,
);
# Check for improper arguments
if (
(defined $switch && $switch ne '-s' && $switch ne '-w')
|| defined $check
) {
return $self->improper($session, $inputString);
}
# Compile a list of workspace grids
# ;lwg
if (! defined $switch) {
push (@list,
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('gridHash'))
);
# Don't modify confirmation message
$string = '';
# ;lwg -s
# ;lwg -s <num>
} elsif ($switch eq '-s') {
if (! defined $num) {
$num = $session->number;
}
$thisSession = $axmud::CLIENT->ivShow('sessionHash', $num);
if (! $thisSession) {
return $self->error(
$session, $inputString,
'Session #' . $num . ' doesn\'t exist',
);
} else {
foreach my $thisWorkspaceObj (
sort {$a->number <=> $b->number}
($axmud::CLIENT->desktopObj->ivValues('workspaceHash'))
) {
my $thisGridObj = $thisWorkspaceObj->findWorkspaceGrid($thisSession);
if ($thisGridObj) {
push (@list, $thisGridObj);
}
}
}
# Modify confirmation message
$string = 'matching';
# ;lwg -w <num>
} elsif ($switch eq '-w') {
if (! defined $num) {
$num = 0;
}
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $num);
if (! $workspaceObj) {
return $self->error(
$session, $inputString,
'Workspace #' . $num . ' doesn\'t exist',
);
} else {
push (@list,
sort {$a->number <=> $b->number} ($workspaceObj->ivValues('gridHash')),
);
}
# Modify confirmation message
$string = 'matching';
}
if (! @list) {
return $self->error(
$session, $inputString,
'No ' . $string . ' workspace grids found',
);
}
# Display header
if (! defined $switch) {
$session->writeText('List of all workspace grids');
} elsif ($switch eq '-s') {
$session->writeText('List of workspace grids for session #' . $session->number);
} elsif ($switch eq '-w') {
$session->writeText('List of workspace grids for workspace #' . $num);
}
# Display list
foreach my $gridObj (@list) {
my $string;
$string = ' Workspace grid #' . $gridObj->number . ' (workspace #'
. $gridObj->workspaceObj->number . ', ';
if ($gridObj->owner) {
$string .= 'session #' . $gridObj->owner->number . ')';
} else {
$string .= 'shared between sessions)';
}
$session->writeText($string);
$session->writeText(' Zonemap: ' . $gridObj->zonemap);
$string = ' Layers: Max ' . $gridObj->maxLayers . ' default '
. $gridObj->defaultLayer . ' current ';
if (defined $gridObj->currentLayer) {
$string .= $gridObj->currentLayer;
} else {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('setlayer', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['layer', 'setlayer'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Sets the session\'s workspace grid layer';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number,
$check,
) = @_;
# Local variables
my (
$count, $errorCount,
@gridList,
);
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Get a list of workspace grids for this session
foreach my $workspaceObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('workspaceHash'))
) {
my $gridObj = $workspaceObj->findWorkspaceGrid($session);
if ($gridObj) {
push (@gridList, $gridObj);
}
}
if (! @gridList) {
return $self->error(
$session, $inputString,
'No workspace grids found for this session',
);
}
# ;layer
if (! defined $number) {
# Display header
$session->writeText('Workspace grid layers for this session');
$session->writeText(' Grid Current Default Max');
foreach my $gridObj (@gridList) {
$session->writeText(
sprintf(
' %-4.4s %-8.8s %-8.8s %-8.8s',
$gridObj->number,
$gridObj->currentLayer,
$gridObj->defaultLayer,
$gridObj->maxLayers,
),
);
}
if (scalar (@gridList) == 1) {
return $self->complete(
$session, $standardCmd,
'End of list (1 workspace grid found)',
);
} else {
return $self->complete(
$session, $standardCmd,
'End of list (' . (scalar @gridList) . ' workspace grids found)',
);
}
# ;layer <number>
} else {
# Check <number> is a valid integer, at least
if (! $axmud::CLIENT->intCheck($number, 0)) {
return $self->error(
$session, $inputString,
'Invalid layer number \'' . $number . '\'',
);
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('layerup', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['lup', 'layerup'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Moves up the session\'s workspace grid layer';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch,
$check,
) = @_;
# Local variables
my (
$count, $errorCount, $mainLayer,
@gridList,
);
# Check for improper arguments
if ((defined $switch && $switch ne '-l') || defined $check) {
return $self->improper($session, $inputString);
}
# Get a list of workspace grids for this session
foreach my $workspaceObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('workspaceHash'))
) {
my $gridObj = $workspaceObj->findWorkspaceGrid($session);
if ($gridObj) {
push (@gridList, $gridObj);
}
}
if (! @gridList) {
return $self->error(
$session, $inputString,
'No workspace grids found for this session',
);
}
# Set the grid layer and restack windows in all zones
$count = 0;
$errorCount = 0;
foreach my $gridObj (@gridList) {
# Check this grid isn't already at its highest layer
if ($gridObj->currentLayer >= ($gridObj->maxLayers - 1)) {
$errorCount++;
} else {
$count++;
$gridObj->inc_currentLayer();
foreach my $zoneObj ($gridObj->ivValues('zoneHash')) {
$zoneObj->restackWin();
}
if ($session->mainWin->workspaceGridObj eq $gridObj) {
$mainLayer = $gridObj->currentLayer;
}
}
}
# Restore focus to the session's 'main' window
$session->mainWin->restoreFocus();
if (! $count) {
if ($switch) {
return $self->error(
$session, $inputString,
'Unable to set the workspace grid layer in any workspace grid',
);
} else {
return $self->complete($session, $standardCmd, 'Window layer is unchanged');
}
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('layerdown', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['ldn', 'ldown', 'layerdown'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Moves down the session\'s workspace grid layer';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch,
$check,
) = @_;
# Local variables
my (
$count, $errorCount, $mainLayer,
@gridList,
);
# Check for improper arguments
if ((defined $switch && $switch ne '-l') || defined $check) {
return $self->improper($session, $inputString);
}
# Get a list of workspace grids for this session
foreach my $workspaceObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('workspaceHash'))
) {
my $gridObj = $workspaceObj->findWorkspaceGrid($session);
if ($gridObj) {
push (@gridList, $gridObj);
}
}
if (! @gridList) {
return $self->error(
$session, $inputString,
'No workspace grids found for this session',
);
}
# Set the grid layer and restack windows in all zones
$count = 0;
$errorCount = 0;
foreach my $gridObj (@gridList) {
# Check this grid isn't already at its highest layer
if ($gridObj->currentLayer == 0) {
$errorCount++;
} else {
$count++;
$gridObj->dec_currentLayer();
foreach my $zoneObj ($gridObj->ivValues('zoneHash')) {
$zoneObj->restackWin();
}
if ($session->mainWin->workspaceGridObj eq $gridObj) {
$mainLayer = $gridObj->currentLayer;
}
}
}
# Restore focus to the session's 'main' window
$session->mainWin->restoreFocus();
if (! $count) {
if ($switch) {
return $self->error(
$session, $inputString,
'Unable to set the workspace grid layer in any workspace grid',
);
} else {
return $self->complete($session, $standardCmd, 'Window layer is unchanged');
}
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('togglewindowstorage', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['tws', 'togglewinstore', 'togglewindowstorage'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Toggles storage of \'grid\' window sizes/positions';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
) = @_;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Toggle the flag
if (! $axmud::CLIENT->storeGridPosnFlag) {
$axmud::CLIENT->set_storeGridPosnFlag(TRUE);
# Store the size/position of all 'grid' windows for this session
$axmud::CLIENT->desktopObj->storeGridWinPosn($session);
return $self->complete(
$session, $standardCmd,
'Storage of \'grid\' window sizes/positions has been turned ON',
);
} else {
$axmud::CLIENT->set_storeGridPosnFlag(FALSE);
return $self->complete(
$session, $standardCmd,
'Storage of \'grid\' window sizes/positions has been turned OFF',
);
}
}
}
{ package Games::Axmud::Cmd::ApplyWindowStorage;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('applywindowstorage', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['aws', 'applywinstore', 'applywindowstorage'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Stores size/position of all \'grid\' windows';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
) = @_;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Store the size/position of all 'grid' windows for this session
$axmud::CLIENT->desktopObj->storeGridWinPosn($session);
return $self->complete(
$session, $standardCmd,
'Sizes/positions of this session\'s \'grid\' windows have been stored',
);
}
}
{ package Games::Axmud::Cmd::ClearWindowStorage;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('clearwindowstorage', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['cws', 'clearwinstore', 'clearwindowstorage'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Clears stored \'grid\' window sizes/positions';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$winName,
$check,
) = @_;
# Check for improper arguments
if (defined $check) {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('deletezonemap', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['dzm', 'delzm', 'deletezm', 'deletezonemap'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Deletes a zonemap';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$name,
$check,
) = @_;
# Check for improper arguments
if (! defined $name || defined $check) {
return $self->improper($session, $inputString);
}
# Check the zonemap exists
if (! $axmud::CLIENT->ivExists('zonemapHash', $name)) {
return $self->error(
$session, $inputString,
'The zonemap \'' . $name . '\' doesn\'t exist',
);
# Check it's not a standard zonemap
} elsif ($axmud::CLIENT->ivExists('standardZonemapHash', $name)) {
return $self->error(
$session, $inputString,
'Standard zonemaps like \'' . $name . '\' can\'t be deleted',
);
}
# Check the zonemap isn't in use by any workspace grid
foreach my $gridObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('gridHash'))
) {
if ($gridObj->zonemap && $gridObj->zonemap eq $name) {
return $self->error(
$session, $inputString,
'The zonemap \'' . $name . '\' is currently in use by workspace grid #'
. $gridObj->number . ' (try using \';resetgrid\' first)',
);
}
}
# Delete the zonemap
$axmud::CLIENT->del_zonemap($name);
# Any workspaces using the zonemap as their default zonemap (unlikely after the check above,
# but possible) should be given a new default zonemap
foreach my $workspaceObj ($axmud::CLIENT->desktopObj->ivValues('workspaceHash')) {
if ($workspaceObj->defaultZonemap && $workspaceObj->defaultZonemap eq $name) {
if ($axmud::CLIENT->shareMainWinFlag) {
$workspaceObj->set_defaultZonemap('basic');
} else {
$workspaceObj->set_defaultZonemap('single');
}
}
}
# Operation complete
return $self->complete($session, $standardCmd, 'Zonemap \'' . $name . '\' deleted');
}
}
{ package Games::Axmud::Cmd::ResetZonemap;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('resetzonemap', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['rzm', 'resetzm', 'resetzonemap'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Resets a zonemap';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$name,
$check,
) = @_;
# Local variables
my $zonemapObj;
# Check for improper arguments
if (! defined $name || defined $check) {
return $self->improper($session, $inputString);
}
# Check the zonemap exists
$zonemapObj = $axmud::CLIENT->ivShow('zonemapHash', $name);
if (! $zonemapObj) {
return $self->error(
$session, $inputString,
'The zonemap \'' . $name . '\' doesn\'t exist',
);
# Check it's not a standard zonemap
} elsif ($axmud::CLIENT->ivExists('standardZonemapHash', $name)) {
return $self->error(
$session, $inputString,
'Standard zonemaps like \'' . $name . '\' can\'t be reset',
);
}
# Check the zonemap isn't in use by any workspace grid
foreach my $gridObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('gridHash'))
) {
if ($gridObj->zonemap && $gridObj->zonemap eq $name) {
return $self->error(
$session, $inputString,
'The zonemap \'' . $name . '\' is currently in use by workspace grid #'
. $gridObj->number . ' (try using \';resetgrid\' first)',
);
}
}
# Reset the zonemap
if (! $zonemapObj->resetZonemap()) {
return $self->error(
$session, $inputString,
'The zonemap \'' . $name . '\' couldn\'t be reset',
);
} else {
return $self->complete(
$session, $standardCmd,
'The zonemap \'' . $name . '\' has been reset',
);
}
}
}
{ package Games::Axmud::Cmd::ListZonemap;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('listzonemap', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['lzm', 'listzm', 'listzonemap'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Lists all zonemaps';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch,
$check,
) = @_;
# Local variables
my (
$count,
@list,
%defaultHash, %inUseHash,
);
# Check for improper arguments
if ((defined $switch && $switch ne '-s') || defined $check) {
return $self->improper($session, $inputString);
}
# Import a list of zonemap names, sorted alphabetically
@list = sort {lc($a) cmp lc($b)} ($axmud::CLIENT->ivKeys('zonemapHash'));
if (! @list) {
return $self->complete($session, $standardCmd, 'The zonemap list is empty');
}
# Create two hashes to show which zonemaps are the default zonemap in a workspace, and
# which zonemaps are in use in a workspace grid
foreach my $workspaceObj ($axmud::CLIENT->desktopObj->ivValues('workspaceHash')) {
if ($workspaceObj->defaultZonemap) {
$defaultHash{$workspaceObj->defaultZonemap} = undef;
}
foreach my $gridObj ($workspaceObj->ivValues('gridHash')) {
if ($gridObj->zonemap) {
$inUseHash{$gridObj->zonemap} = undef;
}
}
}
# Display header
$session->writeText('List of zonemaps (* in use, D default, @ standard, T temporary)');
$session->writeText(' Name Zones Status');
# Display list
$count = 0;
OUTER: foreach my $name (@list) {
my ($obj, $standardFlag, $string, $fullString);
$obj = $axmud::CLIENT->ivShow('zonemapHash', $name);
if (! $axmud::CLIENT->ivExists('standardZonemapHash', $name)) {
if ($switch) {
# This isn't a standard zonemap, so don't list it
next OUTER;
}
} else {
$count++;
$standardFlag = TRUE;
}
if (exists $inUseHash{$name}) {
$string = ' *';
} else {
$string = ' ';
}
if (exists $defaultHash{$name}) {
$string .= 'D';
} else {
$string .= ' ';
}
if ($standardFlag) {
$string .= '@ ';
} elsif ($obj->tempFlag) {
$string .= 'T ';
} else {
$string .= ' ';
}
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
{ package Games::Axmud::Cmd::SwapWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('swapwindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['swn', 'swapwin', 'swapwindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Swaps the size and position of two windows';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$win1, $win2,
$check,
) = @_;
# Local variables
my ($winObj1, $winObj2);
# Check for improper arguments
if (! defined $win1 || ! defined $win2 || defined $check) {
return $self->improper($session, $inputString);
}
# Check the window objects exist
$winObj1 = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $win1);
if (! $winObj1) {
return $self->error(
$session, $inputString,
'Window #' . $win1 . ' doesn\'t seem to exist (try \';listwindow\')',
);
}
$winObj2 = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $win2);
if (! $winObj2) {
return $self->error(
$session, $inputString,
'Window #' . $win2 . ' doesn\'t seem to exist (try \';listwindow\')',
);
}
# Windows can't be swapped with themselves
if ($win1 == $win2) {
return $self->error(
$session, $inputString,
$axmud::SCRIPT . ' can\'t muster the enthusiasm for swapping windows with'
. ' themselves',
);
}
# 'grid' windows in a workspace without workspace grids can't be swapped
if (! $winObj1->workspaceObj->gridEnableFlag || ! $winObj2->workspaceObj->gridEnableFlag) {
return $self->error(
$session, $inputString,
'Windows can\'t be swapped when they\'re not arranged on a workspace grid',
);
}
# Swap the windows
if (! $axmud::CLIENT->desktopObj->swapGridWin($winObj1, $winObj2)) {
return $self->error(
$session, $inputString,
'Windows #' . $win1 . ' and #' . $win2 . ' could not be swapped',
);
} else {
return $self->complete(
$session, $standardCmd,
'Windows #' . $win1 . ' and #' . $win2 . ' have been swapped',
);
}
}
}
{ package Games::Axmud::Cmd::MoveWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('movewindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['mwn', 'movewin', 'movewindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Moves a window into a new zone';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args
) = @_;
# Local variables
my (
$switch, $resizeFlag, $winNum, $workspaceNum, $zoneNum, $winObj, $workspaceObj,
$gridObj, $zoneObj,
);
# Extract switches
($switch, @args) = $self->extract('-r', 0, @args);
if (defined $switch) {
$resizeFlag = TRUE;
} else {
$resizeFlag = FALSE;
}
# Extract remaining arguments
$winNum = shift @args;
$workspaceNum = shift @args;
$zoneNum = shift @args;
# Check for improper arguments
if (! defined $winNum || ! defined $workspaceNum || @args) {
return $self->improper($session, $inputString);
}
# Check the window exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' doesn\'t exist (try \';listwindow\' first)',
);
}
# Check the workspace exists
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $workspaceNum);
if (! $workspaceObj) {
return $self->error(
$session, $inputString,
'Workspace #' . $workspaceNum . ' doesn\'t exist (try \';listworkspace\' first)',
);
}
# Find the session's workspace grid on the specified workspace (this also checks that
# workspaces grids are enabled there at all)
$gridObj = $workspaceObj->findWorkspaceGrid($winObj->session);
if (! $gridObj) {
if (! $workspaceObj->gridEnableFlag) {
return $self->error(
$session, $inputString,
'Workspace grids are not activated in workspace #' . $workspaceNum . ', so the'
. ' window can\'t be moved there',
);
} else {
return $self->error(
$session, $inputString,
'General error moving window to workspace #' . $workspaceNum,
);
}
}
# If it was specified, check the zone exists on the workspace grid
if (defined $zoneNum) {
$zoneObj = $gridObj->ivShow('zoneHash', $zoneNum);
if (! $zoneObj) {
return $self->error(
$session, $inputString,
'Workspace grid #' . $gridObj->number . ' doesn\'t contain a zone #' . $zoneNum,
);
}
} else {
# Choose a zone for ourselves. First check that the workspace grid actually contains
# some zones
if (! $gridObj->zoneHash) {
return $self->error(
$session, $inputString,
'Workspace grid #' . $gridObj->number . ' doesn\'t contain any zones',
);
}
$zoneObj = $workspaceObj->chooseZone(
$gridObj,
$winObj->winType,
$winObj->winName,
$winObj->winWidget,
undef,
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('restorewindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['rwn', 'restorewin', 'restorewindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Restores windows to their former size/position';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$winNum,
$check,
) = @_;
# Local variables
my (
$winObj,
@winList,
%zoneHash,
);
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# ;rwn
if (! defined $winNum) {
# Use all 'grid' windows
@winList = $axmud::CLIENT->desktopObj->listGridWins();
if (! @winList) {
return $self->error(
$session, $inputString,
'No \'grid\' windows found',
);
}
# ;rwn <number>
} else {
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' doesn\'t exist (try \';listwindow\' first)',
);
} else {
push (@winList, $winObj);
}
}
# Restore each window on the list in turn
foreach my $thisWinObj (@winList) {
$thisWinObj->workspaceObj->moveResizeWin(
$thisWinObj,
$thisWinObj->areaObj->xPosPixels,
$thisWinObj->areaObj->yPosPixels,
$thisWinObj->areaObj->widthPixels,
$thisWinObj->areaObj->heightPixels,
);
# Windows in any affected zones most be restacked
$zoneHash{$thisWinObj->areaObj->zoneObj} = $thisWinObj->areaObj->zoneObj;
}
# Re-stack windows
foreach my $zoneObj (values %zoneHash) {
$zoneObj->restackWin();
}
# Operation complete
if ((scalar @winList) == 1) {
$winObj = $winList[0];
return $self->complete(
$session, $standardCmd,
'Window #' . $winObj->number . ' restored to its original size and position',
);
} else {
return $self->complete(
$session, $standardCmd,
scalar (@winList) . ' windows restored to their original size and position',
);
}
}
}
{ package Games::Axmud::Cmd::GrabWindow;
use strict;
use warnings;
# use diagnostics;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('grabwindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['gwn', 'grabwin', 'grabwindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Grabs an \'external\' window onto a workspace grid';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args,
) = @_;
# Local variables
my (
$switch, $allFlag, $workspaceNum, $workspaceFlag, $pattern, $workspaceObj, $gridObj,
$failFlag,
@matchList, @finalList,
);
# Extract switches
($switch, @args) = $self->extract('-a', 0, @args);
if (defined $switch) {
$allFlag = TRUE;
}
($switch, $workspaceNum, @args) = $self->extract('-w', 1, @args);
if (defined $switch) {
$workspaceFlag = TRUE;
}
# Extract remaining arguments
$pattern = shift @args;
# Check for improper arguments
if (! defined $pattern || ($workspaceFlag && ! defined $workspaceNum) || @args) {
return $self->improper($session, $inputString);
}
# Check window grabbing is possible
if (! $axmud::CLIENT->desktopObj->wmCtrlObj) {
return $self->error(
$session, $inputString,
'Sorry, ' . $axmud::SCRIPT . ' is unable to handle external windows on this system',
);
}
# Check $pattern is valid
if ($axmud::CLIENT->regexCheck($pattern)) {
return $self->error(
$session, $inputString,
'The pattern \'' . $pattern . '\' isn\'t a valid regular expression',
);
}
# Set the workspace grid onto which the 'external' window should be grabbed
if ($workspaceFlag) {
$workspaceObj = $axmud::CLIENT->desktopObj->ivShow('workspaceHash', $workspaceNum);
if (! $workspaceObj) {
return $self->error(
$session, $inputString,
'Workspace #' . $workspaceNum . ' doesn\'t exist',
);
}
# Find the session's workspace grid (this also checks ->gridEnableFlag)
$gridObj = $workspaceObj->findWorkspaceGrid($session);
} else {
# Use the workspace for this session's 'main' window
$workspaceObj = $session->mainWin->workspaceObj;
$gridObj = $session->mainWin->workspaceGridObj;
}
if (! $gridObj) {
return $self->error(
$session, $inputString,
'Workspace grids are disactivated on workspace #' . $workspaceNum,
);
}
# Get a list of windows that match the $pattern. List in groups of two, in the form
# (window_title, window_internal_id)
@matchList = $workspaceObj->matchWinList(0, $pattern);
if (! @matchList) {
return $self->error(
$session, $inputString,
'No \'external\' windows matching the pattern \'' . $pattern . '\' found',
);
}
# Now, go through @matchList and remove any windows that have the same name as an Axmud
# 'grid' or 'free' window (which will include any 'external' windows that have already
# been grabbed)
do {
my ($title, $id, $matchFlag);
$title = shift @matchList;
$id = shift @matchList;
OUTER: foreach my $winObj (
$axmud::CLIENT->desktopObj->ivValues('gridWinHash'),
$axmud::CLIENT->desktopObj->ivValues('freeWinHash'),
) {
if ($winObj->winWidget->get_title() eq $title) {
$matchFlag = TRUE;
last OUTER;
}
}
if (! $matchFlag) {
push (@finalList, $title, $id);
}
} until (! @matchList);
# Display an error if there are no windows in @finalList
if (! @finalList) {
return $self->error(
$session, $inputString,
'No \'external\' windows matching the pattern \'' . $pattern . '\' found',
);
}
# Incorporate all the windows in @finalList into the workspace grid
do {
my ($title, $id);
$title = shift @finalList;
$id = shift @finalList;
if (
! $workspaceObj->createGridWin(
'external',
$title, # Window name
$title, # Window title
undef, # No winmap
undef, # Default package name
undef, # Gtk3::Window currently unknown...
$id, # ...but we know the X11::WMCtrl internal ID
$session, # Owner
$session, # Session
$gridObj->number,
)
) {
$failFlag = TRUE;
last OUTER;
}
} until (! @finalList);
if ($failFlag) {
if (@finalList == 1) {
return $self->error(
$session, $inputString,
'Failed to grab 1 window matching the pattern \'' . $pattern . '\'',
);
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('banishwindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['bwn', 'banwin', 'banishwin', 'banishwindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Removes an \'external\' window from a workspace grid';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$winNum,
$check,
) = @_;
# Local variables
my (
$winObj,
@winList,
);
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# ;bw
if (! defined $winNum) {
# Get a list of all 'external' windows
@winList = $axmud::CLIENT->desktopObj->listGridWins('external');
# ;bw <number>
} else {
# Check that $winNum is a valid number (the error message if the window doesn't
# exist would read 'Window #firefox doesn't seem to exist, if we don't perform this
# check')
if (! $axmud::CLIENT->intCheck($winNum, 0)) {
return $self->error(
$session, $inputString,
'Invalid window number \'' . $winNum . '\' (try \';listwindow\' first)',
);
}
# Check the window exists and is an 'external' window
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' doesn\'t exist (try \';listwindow\' first)',
);
} elsif ($winObj->winType ne 'external') {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' isn\'t an \'external\' window',
);
}
# Compile a list of 1 window
@winList = ($winObj);
}
# Banish each window in the list in turn
foreach my $thisWinObj (@winList) {
# Destroy the window object, and update the zone's internal grid and the zone's other
# variables
$thisWinObj->winDisengage();
}
if (defined $winNum) {
return $self->complete(
$session, $standardCmd,
'Window #' . $winNum . ' removed from ' . $axmud::SCRIPT . '\'s workspace grids',
);
} else {
return $self->complete(
$session, $standardCmd,
scalar @winList . ' windows removed from ' . $axmud::SCRIPT . '\'s workspace grids',
);
}
}
}
{ package Games::Axmud::Cmd::FixWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('fixwindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['fwn', 'fixwin', 'fixwindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Fixes a window at its current size/position';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args
) = @_;
# Local variables
my (
$switch, $resizeFlag, $winNum, $winObj, $xPosPixels, $yPosPixels,
$widthPixels, $heightPixels, $zoneObj, $result,
);
# Extract switches
($switch, @args) = $self->extract('-r', 0, @args);
if (defined $switch) {
$resizeFlag = TRUE;
}
# Extract remaining arguments
$winNum = shift @args;
# Check for improper arguments
if (! defined $winNum || @args) {
return $self->improper($session, $inputString);
}
# Check the window exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' doesn\'t exist (try \';listwindow\' first)',
);
# Can't fix windows in workspaces where workspace grids are disabled
} elsif (! $winObj->workspaceObj->gridEnableFlag) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' can\'t be fixed in place on workspace #'
. $winObj->workspaceObj->number . ' because workspace grids are not activated'
. ' there',
);
}
# Get the window's actual size and position
($xPosPixels, $yPosPixels, $widthPixels, $heightPixels)
= $winObj->workspaceObj->getWinGeometry($winObj->winWidget->get_window());
# Find which zone occupies this position
$zoneObj = $winObj->workspaceGridObj->findZone($xPosPixels, $yPosPixels);
if (! $zoneObj) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' can\'t be fixed in place (zone not found)',
);
}
# Try to fix the window
if ($resizeFlag) {
# Move and resize the window
$result = $winObj->workspaceGridObj->changeWinzone(
$winObj,
$zoneObj,
TRUE, # Use default size
);
} else {
# Move the window without resizing
$result = $winObj->workspaceGridObj->changeWinzone(
$winObj,
$zoneObj,
FALSE, # Use current size and width
$widthPixels,
$heightPixels,
);
}
if (! $result) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' could not be fixed in place in zone #' . $zoneObj->number,
);
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('flashwindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['flw', 'flashwin', 'flashwindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Sets a \'grid\' window\'s urgency hint';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number,
$check,
) = @_;
# Local variables
my $winObj;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# ;flw
if (! defined $number) {
$winObj = $session->mainWin;
# ;flw <number>
} else {
# Check the window <number> exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $number);
if (! $winObj) {
return $self->error(
$session, $inputString,
'Window #' . $number . ' doesn\'t exist (try \';listwindow\' first)',
);
}
}
# Set the window's urgency hint. Forcing the setting by using the TRUE flag seems to work
# more reliably, in this case
$winObj->setUrgent(TRUE);
if (! defined $number) {
return $self->complete(
$session, $standardCmd,
'\'Main\' window\'s urgency hint set',
);
} else {
return $self->complete(
$session, $standardCmd,
'\'Grid\' window #' . $number . ' urgency hint set',
);
}
}
}
{ package Games::Axmud::Cmd::UnflashWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('unflashwindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['ufw', 'unflashwin', 'unflashwindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Resets a \'grid\' window\'s urgency hint';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number,
$check,
) = @_;
# Local variables
my $winObj;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# ;ufw
if (! defined $number) {
$winObj = $session->mainWin;
# ;ufw <number>
} else {
# Check the window <number> exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $number);
if (! $winObj) {
return $self->error(
$session, $inputString,
'Window #' . $number . ' doesn\'t exist (try \';listwindow\' first)',
);
}
}
# Set the window's urgency hint. Forcing the setting by using the TRUE flag seems to work
# more reliably, in this case
$winObj->resetUrgent(TRUE);
if (! defined $number) {
return $self->complete(
$session, $standardCmd,
'\'Main\' window\'s urgency hint reset',
);
} else {
return $self->complete(
$session, $standardCmd,
'\'Grid\' window #' . $number . ' urgency hint reset',
);
}
}
}
{ package Games::Axmud::Cmd::CloseWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('closewindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['cwn', 'closewin', 'closewindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Closes a \'grid\' window';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number,
$check,
) = @_;
# Local variables
my ($winObj, $result);
# Check for improper arguments
if (! defined $number || defined $check) {
return $self->improper($session, $inputString);
}
# Check the window <number> exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $number);
if (! $winObj) {
return $self->error(
$session, $inputString,
'Window #' . $number . ' doesn\'t exist (try \';listwindow\' first)',
);
}
# Close the window (if allowed)
if ($winObj->winType eq 'main') {
return $self->error(
$session, $inputString,
'\'main\' windows can\'t be closed with this command',
);
} else {
$result = $winObj->winDestroy();
}
if (! $result) {
return $self->error(
$session, $inputString,
'Window #' . $number . ' (type \'' . $winObj->winType . '\') can\'t be closed',
);
} else {
return $self->complete(
$session, $standardCmd,
'Window #' . $number . ' (type \'' . $winObj->winType . '\') closed',
);
}
}
}
{ package Games::Axmud::Cmd::EditWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('editwindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['ewn', 'editwin', 'editwindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Opens an \'edit\' window for a \'grid\' window';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number, $switch, $objNumber,
$check,
) = @_;
# Local variables
my ($winObj, $stripObj, $tableObj);
# Check for improper arguments
if (
! defined $number
|| (defined $switch && $switch ne '-p' && $switch ne '-t')
|| (defined $switch && ! defined $objNumber)
|| defined $check
) {
return $self->improper($session, $inputString);
}
# Check the window object exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $number);
if (! $winObj) {
return $self->error(
$session, $inputString,
'The \'grid\' window #' . $number . ' doesn\'t exist',
);
}
# ;ewn <number>
if (! $switch) {
# Open an 'edit' window for the 'grid' window
if (
! $session->mainWin->createFreeWin(
'Games::Axmud::EditWin::Window',
$session->mainWin,
$session,
'Edit \'grid\' window #' . $number,
$winObj,
FALSE, # Not temporary
)
) {
return $self->error(
$session, $inputString,
'Could not edit \'grid\' window #' . $number,
);
} else {
return $self->complete(
$session, $standardCmd,
'Opened \'edit\' window for \'grid\' window #' . $number,
);
}
# ;ewn <number> -p <strip>
# ;ewn <number> -t <strip>
} else {
# Check it's an 'internal' window
if (
$winObj->winType ne 'main'
&& $winObj->winType ne 'protocol'
&& $winObj->winType ne 'custom'
) {
return $self->error(
$session, $inputString,
'Window #' . $number . ' is a \'' . $winObj->winType . '\' window; the switches'
. ' -p and -t can only be used with \'internal\' windows',
);
}
# ;ewn <number> -p <strip>
if ($switch eq '-p') {
# Check the strip object exists
$stripObj = $winObj->ivShow('stripHash', $objNumber);
if (! $stripObj) {
return $self->error(
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args,
) = @_;
# Local variables
my (
$switch, $sessionFlag, $flagCount, $workspaceFlag, $gridFlag, $zoneFlag,
@winObjList,
);
# Extract switches
($switch, @args) = $self->extract('-s', 0, @args);
if (defined $switch) {
$sessionFlag = TRUE;
}
$flagCount = 0;
($switch, @args) = $self->extract('-w', 0, @args);
if (defined $switch) {
$workspaceFlag = TRUE;
$flagCount++;
}
($switch, @args) = $self->extract('-g', 0, @args);
if (defined $switch) {
$gridFlag = TRUE;
$flagCount++;
}
($switch, @args) = $self->extract('-z', 0, @args);
if (defined $switch) {
$zoneFlag = TRUE;
$flagCount++;
}
# @args should now contain exactly one argument
if (@args) {
return $self->improper($session, $inputString);
}
# Some switches can't be combined
if ($flagCount > 1) {
return $self->error(
$session, $inputString,
'The switches -w, -g and -z can\'t be combined',
);
}
# Get a list of 'grid' window objects, removing any not controlled by this session if that
# switch was specified
foreach my $winObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('gridWinHash'))
) {
if (! $sessionFlag || ($winObj->session && $winObj->session eq $session)) {
push (@winObjList, $winObj);
}
}
if (! @winObjList) {
if (! $sessionFlag) {
return $self->error(
$session, $inputString,
'No \'grid\' windows found',
);
} else {
return $self->error(
$session, $inputString,
'No \'grid\' windows for this session found',
);
}
}
# Display header
if (! $flagCount || $workspaceFlag) {
$session->writeText(
'List of \'grid\' windows (+ enabled, * visible; position in pixels)',
);
} elsif ($gridFlag) {
$session->writeText(
'List of \'grid\' windows (+ enabled, * visible; grid position in blocks)',
);
} else {
$session->writeText(
'List of \'grid\' windows (+ enabled, * visible; zone internal grid position in'
. ' blocks)',
);
}
$session->writeText(
' Num Type Name Winmap Sesn Wksp Grid Zone Layer'
. ' X/Y Wid/Hei',
);
# Display list
foreach my $winObj (@winObjList) {
my (
$column, $sessionString, $workspaceString, $gridString, $winmapString, $mainString,
$zoneString, $layerString, $posnString, $sizeString,
);
if ($winObj->enabledFlag) {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
{ package Games::Axmud::Cmd::EditWindowStrip;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('editwindowstrip', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['est', 'editstrip', 'editwindowstrip'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Opens an \'edit\' window for a strip object';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$winNum, $stripNum,
$check,
) = @_;
# Local variables
my ($winObj, $stripObj);
# Check for improper arguments
if (! defined $winNum || ! defined $stripNum || defined $check) {
return $self->improper($session, $inputString);
}
# Check the window object exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'The \'grid\' window #' . $winNum . ' doesn\'t exist',
);
}
# Check it's an 'internal' window
if (
$winObj->winType ne 'main'
&& $winObj->winType ne 'protocol'
&& $winObj->winType ne 'custom'
) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' is a \'' . $winObj->winType . '\' window; this command can'
. ' only be used with \'internal\' windows',
);
}
# Check the strip object exists
$stripObj = $winObj->ivShow('stripHash', $stripNum);
if (! $stripObj) {
return $self->error(
$session, $inputString,
'Strip object #' . $stripNum . ' doesn\'t exist in \'grid\' window #'
. $winNum,
);
}
# Open an 'edit' window for the strip object
if (
! $session->mainWin->createFreeWin(
'Games::Axmud::EditWin::Strip',
$session->mainWin,
$session,
'Edit strip object #' . $stripNum,
$stripObj,
FALSE, # Not temporary
)
) {
return $self->error(
$session, $inputString,
'Could not edit strip object #' . $stripNum,
);
} else {
return $self->complete(
$session, $standardCmd,
'Opened \'edit\' window for strip object #' . $stripNum,
);
}
}
}
{ package Games::Axmud::Cmd::ListWindowStrip;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('listwindowstrip', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['lst', 'liststrip', 'listwindowstrip'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Lists strip objects in an \'internal\' window';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args,
) = @_;
# Local variables
my ($switch, $initFlag, $winNum, $winObj, $count);
# Extract switches
($switch, @args) = $self->extract('-i', 0, @args);
if (defined $switch) {
$initFlag = TRUE;
}
# Extract remaining arguments
$winNum = shift @args;
# There should be nothing left in @args
if (! defined $winNum || @args) {
return $self->improper($session, $inputString);
}
# Check the window object exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'The \'grid\' window #' . $winNum . ' doesn\'t exist',
);
}
# Check it's an 'internal' window
if (
$winObj->winType ne 'main'
&& $winObj->winType ne 'protocol'
&& $winObj->winType ne 'custom'
) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' is a \'' . $winObj->winType . '\' window; this command can'
. ' only be used with \'internal\' windows',
);
}
# Display header
$session->writeText(
'List of strip objects in \'grid\' window #' . $winNum . ' (* visible, ^ jealous)',
);
$session->writeText(' Num Type Package name');
# Display list
$count = scalar ($winObj->stripList);
foreach my $stripObj ($winObj->stripList) {
my $column;
if ($stripObj->visibleFlag) {
$column = '*';
} else {
$column = ' ';
}
if ($stripObj->jealousyFlag) {
$column .= '^ ';
} else {
$column .= ' ';
}
$session->writeText(
$column . sprintf(
'%-4.4s %-16.16s %-64.64s',
$stripObj->number,
$stripObj->type,
$stripObj->_objClass,
),
);
if ($switch && $stripObj->initHash) {
$session->writeText(' Initialisation settings');
foreach my $key (sort {lc($a) cmp lc($b)} ($stripObj->ivKeys('initHash'))) {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
{ package Games::Axmud::Cmd::EditWindowTable;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('editwindowtable', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['ewt', 'edittable', 'editwindowtable'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Opens an \'edit\' window for a table object';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$winNum, $tableNum,
$check,
) = @_;
# Local variables
my ($winObj, $tableObj);
# Check for improper arguments
if (! defined $winNum || ! defined $tableNum || defined $check) {
return $self->improper($session, $inputString);
}
# Check the window object exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'The \'grid\' window #' . $winNum . ' doesn\'t exist',
);
}
# Check it's an 'internal' window
if (
$winObj->winType ne 'main'
&& $winObj->winType ne 'protocol'
&& $winObj->winType ne 'custom'
) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' is a \'' . $winObj->winType . '\' window; this command can'
. ' only be used with \'internal\' windows',
);
}
# Check the table object exists
$tableObj = $winObj->tableStripObj->ivShow('tableObjHash', $tableNum);
if (! $tableObj) {
return $self->error(
$session, $inputString,
'Table object #' . $tableNum . ' doesn\'t exist in \'grid\' window #'
. $winNum,
);
}
# Open an 'edit' window for the table object
if (
! $session->mainWin->createFreeWin(
'Games::Axmud::EditWin::Table',
$session->mainWin,
$session,
'Edit table object #' . $tableNum,
$tableObj,
FALSE, # Not temporary
)
) {
return $self->error(
$session, $inputString,
'Could not edit table object #' . $tableNum,
);
} else {
return $self->complete(
$session, $standardCmd,
'Opened \'edit\' window for table object #' . $tableNum,
);
}
}
}
{ package Games::Axmud::Cmd::ListWindowTable;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('listwindowtable', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['lwt', 'listtable', 'listwindowtable'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Lists table objects in an \'internal\' window';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
@args,
) = @_;
# Local variables
my ($switch, $initFlag, $winNum, $winObj, $count);
# Extract switches
($switch, @args) = $self->extract('-i', 0, @args);
if (defined $switch) {
$initFlag = TRUE;
}
# Extract remaining arguments
$winNum = shift @args;
# There should be nothing left in @args
if (! defined $winNum || @args) {
return $self->improper($session, $inputString);
}
# Check the window object exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('gridWinHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'The \'grid\' window #' . $winNum . ' doesn\'t exist',
);
}
# Check it's an 'internal' window
if (
$winObj->winType ne 'main'
&& $winObj->winType ne 'protocol'
&& $winObj->winType ne 'custom'
) {
return $self->error(
$session, $inputString,
'Window #' . $winNum . ' is a \'' . $winObj->winType . '\' window; this command can'
. ' only be used with \'internal\' windows',
);
}
# Display header
$session->writeText(
'List of table objects in \'grid\' window #' . $winNum
. ' (m removeable, s resizeable)',
);
$session->writeText(' Num Type Name Package name');
# Display list
$count = $winObj->tableStripObj->ivPairs('tableObjHash');
foreach my $tableObj (
sort {$a->number <=> $b->number} ($winObj->tableStripObj->ivValues('tableObjHash'))
) {
my $column;
if ($tableObj->allowRemoveFlag) {
$column = 'm';
} else {
$column = ' ';
}
if ($tableObj->allowResizeFlag) {
$column .= 's ';
} else {
$column .= ' ';
}
$session->writeText(
$column . sprintf(
'%-4.4s %-16.16s %-16.16s %-64.64s',
$tableObj->number,
$tableObj->type,
$tableObj->name,
$tableObj->_objClass,
),
);
if ($switch && $tableObj->initHash) {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
{ package Games::Axmud::Cmd::EditFreeWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('editfreewindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['efw', 'editfreewin', 'editfreewindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Opens an \'edit\' window for a \'free\' window';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number,
$check,
) = @_;
# Local variables
my $winObj;
# Check for improper arguments
if (! defined $number || defined $check) {
return $self->improper($session, $inputString);
}
# Check the window object exists
$winObj = $axmud::CLIENT->desktopObj->ivShow('freeWinHash', $number);
if (! $winObj) {
return $self->error(
$session, $inputString,
'The \'free\' window #' . $number . ' doesn\'t exist',
);
}
# Open an 'edit' window for the 'free' window
if (
! $session->mainWin->createFreeWin(
'Games::Axmud::EditWin::Window',
$session->mainWin,
$session,
'Edit \'free\' window #' . $number,
$winObj,
FALSE, # Not temporary
)
) {
return $self->error(
$session, $inputString,
'Could not edit \'free\' window #' . $number,
);
} else {
return $self->complete(
$session, $standardCmd,
'Opened \'edit\' window for \'free\' window #' . $number,
);
}
}
}
{ package Games::Axmud::Cmd::CloseFreeWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('closefreewindow', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['cfw', 'closefreewin', 'closefreewindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Closes a \'free\' window';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$number,
$check,
) = @_;
# Local variables
my @winObjList;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# ;cfw
# ;cfw -s
if (! defined $number || $number eq '-s') {
# Get a list of 'free' window objects, removing any not controlled by this session if
# that switch was specified
foreach my $winObj (
sort {$a->number <=> $b->number}
($axmud::CLIENT->desktopObj->ivValues('freeWinHash'))
) {
if (! defined $number || ($winObj->session && $winObj->session eq $session)) {
push (@winObjList, $winObj);
}
}
# ;cfw <number>
} else {
# Check the window object exists, if specified
if (! $axmud::CLIENT->desktopObj->ivExists('freeWinHash', $number)) {
return $self->error(
$session, $inputString,
'The \'free\' window #' . $number . ' doesn\'t exist',
);
} else {
push (@winObjList, $axmud::CLIENT->desktopObj->ivShow('freeWinHash', $number));
}
}
if (! @winObjList) {
if (! defined $number) {
return $self->error(
$session, $inputString,
'No \'free\' windows found',
);
} else {
return $self->error(
$session, $inputString,
'No \'free\' windows for this session found',
);
}
}
# Close each window in turn
foreach my $winObj (@winObjList) {
$winObj->winDestroy();
}
# Operation complete
if (@winObjList == 1) {
return $self->complete($session, $standardCmd, 'Closed 1 \'free\' window');
} else {
return $self->complete(
$session, $standardCmd,
'Closed ' . (scalar @winObjList) . ' \'free\' windows',
);
}
}
}
{ package Games::Axmud::Cmd::ListFreeWindow;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('listfreewindow', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['lfw', 'listfree', 'listfreewin', 'listfreewindow'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Lists \'free\' windows';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch,
$check,
) = @_;
# Local variables
my @winObjList;
# Check for improper arguments
if (
(defined $switch && $switch ne '-s')
|| defined $check
) {
return $self->improper($session, $inputString);
}
# Get a list of 'free' window objects, removing any not controlled by this session if that
# switch was specified
foreach my $winObj (
sort {$a->number <=> $b->number} ($axmud::CLIENT->desktopObj->ivValues('freeWinHash'))
) {
if (! $switch || ($winObj->session && $winObj->session eq $session)) {
push (@winObjList, $winObj);
}
}
if (! @winObjList) {
if (! $switch) {
return $self->error(
$session, $inputString,
'No \'free\' windows found',
);
} else {
return $self->error(
$session, $inputString,
'No \'free\' windows for this session found',
);
}
}
# Display header
$session->writeText('List of \'free\' windows (+ enabled, * visible)');
$session->writeText(' Num Type Name Sesn Wksp');
# Display list
foreach my $winObj (@winObjList) {
my ($column, $sessionString, $workspaceString);
if ($winObj->enabledFlag) {
$column = '+';
} else {
$column = ' ';
}
if ($winObj->visibleFlag) {
$column .= '* ';
} else {
$column .= ' ';
}
if ($winObj->session) {
$sessionString = $winObj->session->number;
} else {
$sessionString = 'n/a';
}
if ($winObj->workspaceObj) {
$workspaceString = $winObj->workspaceObj->number;
} else {
$workspaceString = 'n/a';
}
$session->writeText(
$column . sprintf(
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('cleartextview', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['ctv', 'cls', 'cleartextview'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Removes all text from textview(s)';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch, $number,
$check,
) = @_;
# Local variables
my (
$thisFlag,
@list,
);
# Check for improper arguments
if (
(
defined $switch && $switch ne '-m' && $switch ne '-s' && $switch ne '-w'
&& $switch ne '-t'
) || (
defined $switch && ($switch eq '-m' || $switch eq '-s') && defined $number
) || (
defined $switch && ($switch eq '-w' || $switch eq '-t') && ! defined $number
) || defined $check
) {
return $self->improper($session, $inputString);
}
# Compile a list of textview objects which should be cleared
if (! $switch) {
push (@list, $session->defaultTabObj->textViewObj);
} elsif ($switch eq '-m') {
foreach my $textViewObj ($axmud::CLIENT->desktopObj->ivValues('textViewHash')) {
if ($textViewObj->winObj && $textViewObj->winObj eq $session->mainWin) {
push (@list, $textViewObj);
}
}
} elsif ($switch eq '-s') {
foreach my $textViewObj ($axmud::CLIENT->desktopObj->ivValues('textViewHash')) {
if (
(
$textViewObj->winObj
&& $textViewObj->winObj->visibleSession
&& $textViewObj->winObj->visibleSession eq $session
) || (
$textViewObj->winObj
&& $textViewObj->winObj->session
&& $textViewObj->winObj->session eq $session
)
) {
push (@list, $textViewObj);
}
}
} elsif ($switch eq '-w') {
foreach my $textViewObj ($axmud::CLIENT->desktopObj->ivValues('textViewHash')) {
if ($textViewObj->winObj && $textViewObj->winObj->number eq $number) {
push (@list, $textViewObj);
}
}
} elsif ($switch eq '-t') {
if ($axmud::CLIENT->desktopObj->ivExists('textViewHash', $number)) {
push (@list, $axmud::CLIENT->desktopObj->ivShow('textViewHash', $number));
}
}
if (! @list) {
return $self->error(
$session, $inputString,
'No matching textviews found',
);
} else {
foreach my $textViewObj (@list) {
$textViewObj->clearBuffer();
if ($textViewObj eq $session->defaultTabObj->textViewObj) {
$thisFlag = TRUE;
}
}
if (! $thisFlag) {
if (scalar (@list) == 1) {
return $self->complete($session, $standardCmd, '1 textview emptied');
} else {
return $self->complete(
$session, $standardCmd,
scalar (@list) . ' textviews emptied',
);
}
} else {
# (Don't show a $self->complete message, so that the session's default textview
# remains cleared; just return 1)
return 1;
}
}
}
}
{ package Games::Axmud::Cmd::SetTextView;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
$self->{defaultUserCmdList} = ['stv', 'settv', 'settextview'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Sets the default size of textviews';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$size,
$check,
) = @_;
# Local variables
my $count;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# ;stv
if (! defined $size) {
$axmud::CLIENT->set_customTextBufferSize($axmud::CLIENT->constTextBufferSize);
# ;stv <size>
} else {
if (
! $axmud::CLIENT->intCheck(
$size,
$axmud::CLIENT->constMinBufferSize,
$axmud::CLIENT->constMaxBufferSize,
)
) {
return $self->error(
$session, $inputString,
'Invalid textview size \'' . $size . '\' (must be a number in the range '
. $axmud::CLIENT->constMinBufferSize . '-' . $axmud::CLIENT->constMaxBufferSize
. ')'
);
} else {
$axmud::CLIENT->set_customTextBufferSize($size);
}
}
# Update all existing textview objects (the size is applied only to textview which are
# using a non-zero size, with zero meaning unlimited size)
$count = 0;
foreach my $textViewObj ($axmud::CLIENT->desktopObj->ivValues('textViewHash')) {
if ($textViewObj->maxLines) {
$textViewObj->set_maxLines($axmud::CLIENT->customTextBufferSize);
$count++;
}
}
# Operation complete
return $self->complete(
$session, $standardCmd,
'Textview size set to ' . $axmud::CLIENT->customTextBufferSize . ' (textview objects'
. ' updated: ' . $count . ')',
);
}
}
{ package Games::Axmud::Cmd::ListTextView;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('listtextview', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['ltv', 'listtv', 'listtextview'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Lists textview objects';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
) = @_;
# Local variables
my @list;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Display header
$session->writeText('List of textview objects');
$session->writeText(' Num Win Pane ScrLk SplSc Colour scheme');
# Display list
@list = sort {$a->number <=> $b->number}
($axmud::CLIENT->desktopObj->ivValues('textViewHash'));
foreach my $textViewObj (@list) {
my ($scrollString, $colourString);
if ($textViewObj->scrollLockFlag) {
$scrollString = 'on';
} else {
$scrollString = 'off';
}
if ($textViewObj->colourScheme) {
$colourString = $textViewObj->colourScheme;
} else {
$colourString = 'n/a';
}
$session->writeText(
' ' . sprintf(
'%-4.4s %-4.4s %-4.4s %-5.5s %-5.5s ',
$textViewObj->number,
$textViewObj->winObj->number,
$textViewObj->paneObj->number,
$scrollString,
$textViewObj->splitScreenMode,
) . $colourString,
);
}
# Display footer
if (scalar (@list) == 1) {
return $self->complete(
$session, $standardCmd,
'End of list (1 textview object found)',
);
} else {
return $self->complete(
$session, $standardCmd,
'End of list (' . scalar (@list) . ' textview objects found)',
);
}
}
}
{ package Games::Axmud::Cmd::FindText;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
@args,
) = @_;
# Local variables
my (
$switch, $tvObjNum, $tvObjFlag, $prevFlag, $nextFlag, $caseFlag, $splitFlag, $regex,
$tvObj, $line, $offset, $length,
);
# Extract switches
($switch, $tvObjNum, @args) = $self->extract('-t', 1, @args);
if ($switch) {
$tvObjFlag = TRUE;
}
($switch, @args) = $self->extract('-p', 0, @args);
if ($switch) {
$prevFlag = TRUE;
}
($switch, @args) = $self->extract('-n', 0, @args);
if ($switch) {
$nextFlag = TRUE;
}
($switch, @args) = $self->extract('-c', 0, @args);
if ($switch) {
$caseFlag = TRUE;
}
($switch, @args) = $self->extract('-s', 0, @args);
if ($switch) {
$splitFlag = TRUE;
}
# @args should now containg a single argument
$regex = shift @args;
if (! defined $regex || @args) {
return $self->improper($session, $inputString);
}
# Some switches can't be combined
if ($prevFlag && $nextFlag) {
return $self->error(
$session, $inputString,
'The switches \'-p\' and \'-n\' can\'t be combined',
);
}
# Get the textview object whose buffer should be searched. If none was specified, use the
# session's default tab
if ($tvObjFlag) {
$tvObj = $axmud::CLIENT->desktopObj->ivShow('textViewHash', $tvObjNum);
if (! $tvObj) {
return $self->error(
$session, $inputString,
'There is no textview object numbered \'' . $tvObjNum . '\'',
);
}
} else {
$tvObj = $session->defaultTabObj->textViewObj;
}
# Perform the search
($line, $offset, $length) = $tvObj->searchBuffer($regex, $nextFlag, TRUE, $caseFlag);
if (! defined $line) {
return $self->complete(
$session, $standardCmd,
'No matching text found in textview #' . $tvObj->number,
);
} elsif ($tvObj ne $session->defaultTabObj->textViewObj) {
return $self->complete(
$session, $standardCmd,
'Match found at line ' . $line . ', offset ' . $offset . ', length: ' . $length,
);
} else {
# Don't show a confirmation if a match is found in the session's default textview (as it
# makes the textview scroll)
return 1;
}
}
}
{ package Games::Axmud::Cmd::FindReset;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('findreset', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['frt', 'findreset'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Resets the last find operation';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$tvObjNum,
$check,
) = @_;
# Local variables
my $tvObj;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# Get the textview object whose search mark should be reset. If none was specified, use the
# session's default tab
if (defined $tvObjNum) {
$tvObj = $axmud::CLIENT->desktopObj->ivShow('textViewHash', $tvObjNum);
if (! $tvObj) {
return $self->error(
$session, $inputString,
'There is no textview object numbered \'' . $tvObjNum . '\'',
);
}
} else {
$tvObj = $session->defaultTabObj->textViewObj;
}
# Reset the textview's search mark
$tvObj->setSearchMark();
# Un-select any selected text
$tvObj->unselectText();
if ($tvObj ne $session->defaultTabObj->textViewObj) {
return $self->complete(
$session, $standardCmd,
'The search position in textview #' . $tvObj->number . ' has been reset',
);
} else {
return $self->complete(
$session, $standardCmd,
'The search position in the session\'s default textview has been reset',
);
}
}
}
{ package Games::Axmud::Cmd::ConvertText;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# Check $tag is a standard colour tag
($tagType, $underlayFlag) = $axmud::CLIENT->checkColourTags($tag);
if (! $tagType) {
return $self->error(
$session, $inputString,
'Unrecognised colour tag \'' . $tag . '\'',
);
} elsif ($tagType ne 'standard' || $underlayFlag) {
return $self->error(
$session, $inputString,
'\'' . $tag . '\' is not a standard colour tag (e.g. \'red\', \'BLUE\')',
);
}
# Check $new is a recognised colour tag, if specified
if (defined $new) {
($newType, $newUnderlayFlag) = $axmud::CLIENT->checkColourTags($new);
if (! $newType) {
return $self->error(
$session, $inputString,
'Unrecognised colour tag \'' . $new . '\'',
);
}
}
# ;sco <tag> <colour>
if (defined $new) {
# If <colour> is an underlay tag, convert it into a text tag
if ($newUnderlayFlag) {
$new = $axmud::CLIENT->swapColours($new);
($newType, $newUnderlayFlag) = $axmud::CLIENT->checkColourTags($new);
}
# ;sco <tag>
} else {
if (! $axmud::CLIENT->checkBoldTags($tag)) {
$new = $axmud::CLIENT->ivShow('constColourTagHash', $tag);
} else {
$new = $axmud::CLIENT->ivShow('constBoldColourTagHash', $tag);
}
}
# Convert <colour> to an RGB tag (if it's not already an RGB tag) and update the IV
$new = $axmud::CLIENT->returnRGBColour($new);
if (! $axmud::CLIENT->checkBoldTags($tag)) {
$axmud::CLIENT->set_standardColourTag($tag, $new, FALSE);
} else {
$axmud::CLIENT->set_standardColourTag($tag, $new, TRUE);
}
# Update textview objects
foreach my $textViewObj ($axmud::CLIENT->desktopObj->ivValues('textViewHash')) {
my $tabObj;
# Update the textview object's Gtk3::TextTag
$textViewObj->updateStandardTag($tag);
# Update any textview object in monochrome mode
if (
$textViewObj->monochromeFlag
&& ($textViewObj->textColour eq $tag || $textViewObj->backgroundColour eq $tag)
) {
$tabObj = $textViewObj->paneObj->findTextView($textViewObj);
if ($tabObj) {
$textViewObj->paneObj->applyMonochrome(
$tabObj,
$textViewObj->backgroundColour,
$textViewObj->textColour,
);
}
}
}
# Update any colour scheme using the standard colour tag (doesn't affect any textview
# objects in monochrome mode)
foreach my $schemeObj ($axmud::CLIENT->ivValues('colourSchemeHash')) {
if (
$schemeObj->textColour eq $tag
|| $schemeObj->underlayColour eq $axmud::CLIENT->swapColours($tag)
|| $schemeObj->backgroundColour eq $tag
) {
$session->pseudoCmd('updatecolourscheme ' . $schemeObj->name, 'hide_complete');
}
}
return $self->complete(
$session, $standardCmd,
'Standard colour tag \'' . $tag . '\' set to ' . $new,
);
}
}
{ package Games::Axmud::Cmd::ListColour;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$switch,
$check,
) = @_;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
if (! defined $switch) {
return $self->complete(
$session, $standardCmd,
'Current xterm-256 colour cube: ' . $axmud::CLIENT->currentColourCube,
);
} elsif ($switch ne '-x' && $switch ne '-n') {
return $self->error(
$session, $inputString,
'Invalid switch (try \'-x\' for the xterm cube, or \'-n\' for the netscape cube',
);
} else {
if ($switch eq '-x') {
if ($axmud::CLIENT->currentColourCube eq 'xterm') {
return $self->error(
$session, $inputString,
'The xterm-256 colour cube in use is already \'xterm\'',
);
} else {
$axmud::CLIENT->set_currentColourCube('xterm');
}
} elsif ($switch eq '-n') {
if ($axmud::CLIENT->currentColourCube eq 'netscape') {
return $self->error(
$session, $inputString,
'The xterm-256 colour cube in use is already \'netscape\'',
);
} else {
$axmud::CLIENT->set_currentColourCube('netscape');
}
}
# Update xterm colour tags in all textviews
foreach my $textViewObj ($axmud::CLIENT->desktopObj->ivValues('textViewHash')) {
$textViewObj->updateXTermTags();
}
# Update colour schemes in all 'internal' windows
foreach my $winObj ($axmud::CLIENT->desktopObj->listGridWins('internal')) {
$winObj->updateColourScheme();
}
return $self->complete(
$session, $standardCmd,
'The xterm-256 colour cube has been set to \'' . $axmud::CLIENT->currentColourCube
. '\'',
);
}
}
}
{ package Games::Axmud::Cmd::TogglePalette;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('togglepalette', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['tgp', 'togglepalette'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Toggles use of the OSC colour palette';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('updatecolourscheme', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = [
'ucs', 'updatescheme', 'updatecolorscheme', 'updatecolourscheme',
];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Updates \'internal\' windows using a colour scheme';
# Bless the object into existence
bless $self, $class;
return $self;
}
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$name,
$check,
) = @_;
# Local variables
my $obj;
# Check for improper arguments
if (! defined $name || defined $check) {
return $self->improper($session, $inputString);
}
# Check the colour scheme exists
$obj = $axmud::CLIENT->ivShow('colourSchemeHash', $name);
if (! $obj) {
return $self->error(
$session, $inputString,
'The colour scheme \'' . $name . '\' doesn\'t exist',
);
}
# Check the colour scheme's colour tags are valid, before trying to apply them to 'interal'
# windows (e.g. don't use an underlay colour tag like 'ul_black' for text)
$obj->repair();
# Update textviews in any 'internal' window using this colour scheme
foreach my $winObj ($axmud::CLIENT->desktopObj->listGridWins('internal')) {
$winObj->updateColourScheme($name);
}
# Operation complete
return $self->complete(
$session, $standardCmd,
'All \'internal\' windows using the colour scheme \'' . $name . '\' updated',
);
}
##################
# Methods
}
{ package Games::Axmud::Cmd::ApplyColourScheme;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('applycolourscheme', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = [
'apl', 'applyscheme', 'applycolorscheme', 'applycolourscheme',
];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Applies a colour scheme to \'internal\' windows';
# Bless the object into existence
bless $self, $class;
return $self;
}
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
($switch, @args) = $self->extract('-c', 0, @args);
if ($switch) {
$customFlag = TRUE;
}
($switch, @args) = $self->extract('-s', 0, @args);
if ($switch) {
$sessionFlag = TRUE;
}
($switch, $winNum, @args) = $self->extract('-w', 1, @args);
if ($switch) {
# Check the 'grid' window exists
my $winObj = $axmud::CLIENT->ivShow('gridcheckHash', $winNum);
if (! $winObj) {
return $self->error(
$session, $inputString,
'\'Grid\' window #' . $winNum . ' doesn\'t exist',
);
} elsif (
$winObj->winType ne 'main'
&& $winObj->winType ne 'protocol'
&& $winObj->winType ne 'fixed'
) {
return $self->error(
$session, $inputString,
'\'Grid\' window #' . $winNum . ' isn\'t an \'internal\' window',
);
# Don't add duplicates to this list of window objects to which the colour scheme
# should be applied
} elsif (! exists $checkHash{$winNum}) {
push (@winList, $winObj);
}
}
# @args should now be empty
if (! defined $name || @args) {
return $self->improper($session, $inputString);
}
# Check the colour scheme exists
$schemeObj = $axmud::CLIENT->ivShow('colourSchemeHash', $name);
if (! $schemeObj) {
return $self->error(
$session, $inputString,
'The colour scheme \'' . $name . '\' doesn\'t exist',
);
}
# Get a list of 'internal' windows to which the colour scheme should be applied
foreach my $winObj ($axmud::CLIENT->desktopObj->listGridWins('internal')) {
if (
! exists $checkHash{$winObj->number}
&& (! $mainFlag || $winObj->winType eq 'main')
&& (! $protocolFlag || $winObj->winType eq 'protocol')
&& (! $customFlag || $winObj->winType eq 'custom')
&& (
! $sessionFlag
|| (
$winObj->winType eq 'main'
&& (
$axmud::CLIENT->shareMainWinFlag
|| (
$winObj->visibleSession
&& $winObj->visibleSession eq $session
)
)
) || ($winObj->winType ne 'main' && $winObj->session eq $session)
)
) {
push (@winList, $winObj);
}
}
# Apply the colour scheme
foreach my $winObj (@winList) {
$winObj->applyColourScheme($name);
}
if (scalar @winList == 1) {
return $self->complete(
$session, $standardCmd,
'Colour scheme \'' . $name . '\' applied across 1 \'internal\' window',
);
} else {
return $self->complete(
$session, $standardCmd,
'Colour scheme \'' . $name . '\' applied across ' . (scalar @winList)
. ' \'internal\' windows',
);
}
}
##################
# Methods
}
{ package Games::Axmud::Cmd::DeleteColourScheme;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
# Check for improper arguments
if (defined $check) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->improper($session, $inputString);
}
# Check that loading is allowed at all
if (! $axmud::CLIENT->loadDataFlag) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'File load/save is disabled in all sessions',
);
}
# If a file path was not specified, open a file chooser dialog to decide which file to
# import
if (! $importPath) {
$importPath = $session->mainWin->showFileChooser(
'Merge world model',
'open',
);
if (! $importPath) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->complete($session, $standardCmd, 'File(s) not imported');
}
}
# Check that $importPath is a valid compressed file (ending .tar, .tar.gz, .tgz, .gz, .zip,
# .bz2, .tar.bz2, .tbz or .lzma)
if (
! ($importPath =~ m/\.tar$/)
&& ! ($importPath =~ m/\.tgz$/)
&& ! ($importPath =~ m/\.gz$/)
&& ! ($importPath =~ m/\.zip$/)
&& ! ($importPath =~ m/\.bz2$/)
&& ! ($importPath =~ m/\.tbz$/)
&& ! ($importPath =~ m/\.lzma$/)
) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'File(s) not imported (you specified something that doesn\'t appear to be a'
. ' compressed archive, e.g. a .zip or .tar.gz file)',
);
}
# For large files (e.g. world models containing tens of thousands of rooms), we need to
# display an initial message to explain the pause
$session->writeText('Importing file(s)...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Build an Archive::Extract object
$extractObj = Archive::Extract->new(archive => $importPath);
if (! $extractObj) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'No files imported (file decompression error)',
);
}
# Extract the object to a temporary directory
$tempDir = $axmud::DATA_DIR . '/data/temp';
if (! $extractObj->extract(to => $tempDir)) {
$axmud::CLIENT->set_fileFailFlag(TRUE);
return $self->error(
$session, $inputString,
'No files imported (file decompression error)',
);
}
# All the files are now in /data/temp/export. Get a list of paths, relative to $tempDir, of
# all the extracted files
@fileList = @{$extractObj->files}; # e.g. export/tasks.axm
# Convert all the paths into absolute paths
foreach my $file (@fileList) {
$file = $axmud::DATA_DIR . '/data/temp/' . $file;
}
# Extract from @fileList the world model file (there should only be one, if any)
OUTER: foreach my $file (@fileList) {
my (
$matchFlag,
%headerHash,
);
# Ignore files that don't end with a compatible file extension (like .axm)
INNER: foreach my $ext (@axmud::COMPAT_EXT_LIST) {
if ($file =~ m/\.$ext$/) {
$matchFlag = TRUE;
last INNER;
}
}
if (! $matchFlag) {
next OUTER;
}
# Check it's really an Axmud file by loading the file into a hash
%headerHash = $axmud::CLIENT->configFileObj->examineDataFile($file, 'return_header');
if (
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
if (! $hashRef) {
# ->lock_retrieve() failed
return $self->error(
$session, $inputString,
'Failed to merge the world model file (internal error)',
);
}
# Retrieve the world model itself
$wmObj = $$hashRef{'world_model_obj'};
if (
! $wmObj
# After v1.0.868
|| (exists $wmObj->{_objName} && $wmObj->{_objName} ne 'world_model')
# Before v1.0.868
|| (exists $wmObj->{_name} && $wmObj->{_name} ne 'world_model')
) {
return $self->error(
$session, $inputString,
'The specified archive doesn\'t contain a readable world model file',
);
}
# Much of the code in GA::Obj::File for updating data from previous Axmud versions
# assumes that every GA::Session has a world model; this means that we can't simply
# call GA::Obj::File->updateExtractedData for this extra world model
# Solution is to create a fake (temporary) session and assign the imported world model
# to it
$tempSession = Games::Axmud::Session->new(-1, $session->currentWorld->name);
$tempSession->ivPoke('worldModelObj', $wmObj);
# Set the 'main' window, as GA::File::Obj->updateExtractedData needs it
$tempSession->ivPoke('mainWin', $session->mainWin);
# Also create a temporary world profile
$tempWorldObj = Games::Axmud::Profile::World->new(
$tempSession,
$session->currentWorld->name,
TRUE,
);
# Also create a temporary file object for the world model
$tempFileObj = Games::Axmud::Obj::File->new(
'worldmodel',
$session->currentWorld->name,
$tempSession,
);
# Also create a temporary map object
$tempMapObj = Games::Axmud::Obj::Map->new($tempSession);
$tempSession->ivPoke('currentWorld', $tempWorldObj);
$tempSession->ivAdd('sessionFileObjHash', 'worldmodel', $tempFileObj);
$tempSession->ivPoke('mapObj', $tempMapObj);
# If the file was created by an earlier version of Axmud, we have to update the model's
# data in the usual way
$fileVersion = $axmud::CLIENT->convertVersion($$hashRef{'script_version'});
if ($fileVersion < $axmud::CLIENT->convertVersion($axmud::VERSION)) {
$session->writeText('Updating data for this ' . $axmud::SCRIPT . ' version...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Now we can update the imported world model
if ($fileVersion < 1_000_868) {
$tempFileObj->update_obj_world_model($wmObj);
}
$tempFileObj->updateExtractedData($fileVersion);
}
# If the imported world model has any temporary regions, remove them
$wmObj->deleteTempRegions($tempSession, FALSE);
# To avoid unforeseen complications, get rid of the temporary objects immediately
$tempSession = undef;
$tempWorldObj = undef;
$tempFileObj = undef;
$tempMapObj = undef;
# Now we're ready to merge one model into another
$session->writeText('Merging data...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Pass this imported world model to this session's own model, so it can merge rooms, labels
# and so on
if (! $session->worldModelObj->mergeModel($session, $wmObj)) {
return $self->error(
$session, $inputString,
'The specified archive contained a readable world model file, but ' . $axmud::SCRIPT
. ' was not able to merge its contents into the existing world model',
);
}
$session->writeText('Running model test...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
# Run the usual model test
($errorCount, $fixCount, @outputList) = $session->worldModelObj->testModel(
$session,
FALSE, # Don't problems
TRUE, # Use a list of return values
);
if ($errorCount) {
$session->writeText(
'Model test reports the following inconsistencies (use \';testmodel -f\' to fix'
. ' them):',
);
}
# That's the end of the test. Display any output
foreach my $msg (@outputList) {
$session->writeText($msg);
}
return $self->complete(
$session, $standardCmd,
'Merge operation complete (new regions: ' . $wmObj->ivPairs('regionmapHash')
. ', new rooms: ' . $wmObj->ivPairs('roomModelHash') . ', new exits: '
. $wmObj->ivPairs('exitModelHash') . ')',
);
}
}
{ package Games::Axmud::Cmd::UpdateModel;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('updatemodel', TRUE, FALSE);
if (! $self) {return undef}
lib/Games/Axmud/Cmd.pm view on Meta::CPAN
}
}
{ package Games::Axmud::Cmd::CompressModel;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('compressmodel', TRUE, FALSE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['cmd', 'compmd', 'compressmodel'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Reduces amount of memory used by the world model';
# Bless the object into existence
bless $self, $class;
return $self;
}
##################
# Methods
sub do {
my (
$self, $session, $inputString, $userCmd, $standardCmd,
$check,
) = @_;
# Check for improper arguments
if (defined $check) {
return $self->improper($session, $inputString);
}
# It might be a long wait, so make sure the message is visible right away
$session->writeText('Reducing amount of memory used by world model...');
$axmud::CLIENT->desktopObj->updateWidgets($self->_objClass . '->do');
foreach my $roomObj ($session->worldModelObj->ivValues('roomModelHash')) {
$roomObj->compress();
}
foreach my $exitObj ($session->worldModelObj->ivValues('exitModelHash')) {
$exitObj->compress();
}
# (This line makes sure the correct file object's ->modifyFlag is set)
$session->worldModelObj->ivPoke('author', $session->worldModelObj->author);
return $self->complete(
$session, $standardCmd,
'Operation complete (don\'t forget to \';save\' the changes)',
);
}
}
{ package Games::Axmud::Cmd::ModelReport;
use strict;
use warnings;
# use diagnostics;
use Glib qw(TRUE FALSE);
our @ISA = qw(Games::Axmud::Generic::Cmd Games::Axmud);
##################
# Constructors
sub new {
# Create a new instance of this command object (there should only be one)
#
# Expected arguments
# (none besides $class)
#
# Return values
# 'undef' if GA::Generic::Cmd->new reports an error
# Blessed reference to the new object on success
my ($class, $check) = @_;
# Setup
my $self = Games::Axmud::Generic::Cmd->new('modelreport', TRUE, TRUE);
if (! $self) {return undef}
$self->{defaultUserCmdList} = ['mrp', 'modelreport'];
$self->{userCmdList} = \@{$self->{defaultUserCmdList}};
$self->{descrip} = 'Compiles a report on the world model';
# Bless the object into existence
bless $self, $class;
return $self;
}
( run in 3.817 seconds using v1.01-cache-2.11-cpan-f56aa216473 )