666 lines
19 KiB
Perl
Executable File
666 lines
19 KiB
Perl
Executable File
#! /usr/bin/perl
|
|
#########################################################################################################
|
|
##
|
|
## Name: mzftool.pl
|
|
## Created: August 2018
|
|
## Author(s): Philip Smart
|
|
## Description: Sharp MZ series MZF (Sharp Tape File) management tool.
|
|
## This script identifies the type of MZF file and can add or delete headers as required.
|
|
## Useful for seperating MZF compilations into Basic/Pascal/Machine Code etc.
|
|
## Also useful to add headers to homegrow machine code programs.
|
|
##
|
|
## Credits:
|
|
## Copyright: (c) 2018 Philip Smart <philip.smart@net2net.org>
|
|
##
|
|
## History: August 2018 - Initial script written.
|
|
##
|
|
#########################################################################################################
|
|
## This source file is free software: you can redistribute it and#or modify
|
|
## it under the terms of the GNU General Public License as published
|
|
## by the Free Software Foundation, either version 3 of the License, or
|
|
## (at your option) any later version.
|
|
##
|
|
## This source file is distributed in the hope that it will be useful,
|
|
## but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
## GNU General Public License for more details.
|
|
##
|
|
## You should have received a copy of the GNU General Public License
|
|
## along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
#########################################################################################################
|
|
|
|
# Title and Versioning.
|
|
#
|
|
$TITLE = "MZF Tool";
|
|
$VERSION = "0.1";
|
|
$VERSIONDATE = "25.09.2018";
|
|
|
|
# Global Modules.
|
|
#
|
|
#use strict
|
|
use Getopt::Long;
|
|
use IO::File;
|
|
use File::stat;
|
|
use File::Copy;
|
|
use Time::localtime;
|
|
use POSIX qw(tmpnam);
|
|
use Env qw(KPLUSHOME3 SYBASE SYBASE_OCS DSQUERY);
|
|
use sigtrap qw(die normal-signals);
|
|
|
|
# Error return codes.
|
|
#
|
|
$ERR_BADFILENAME = 1;
|
|
$ERR_BADFILEDATA = 2;
|
|
$ERR_BADFILECREATE = 3;
|
|
$ERR_BADFUNCARGS = 4;
|
|
$ERR_BADSYSCALL = 5;
|
|
$ERR_BADCHECK = 6;
|
|
$ERR_BADENV = 7;
|
|
$ERR_SYBSERVER = 8;
|
|
$ERR_BADARGUMENTS = 9;
|
|
|
|
# Run-time constants.
|
|
#
|
|
$PROGNAME = $0;
|
|
|
|
# Run-time globals. Although in Perl you can just specify variables, keeping with most
|
|
# high-order languages it is good practise to specify non-local variables in a global header
|
|
# which aids visual variable tracking etc.
|
|
#
|
|
$dbh = 0; # Handle to a Sybase object.
|
|
$logh = 0; # Handle to open log file.
|
|
$logName = ""; # Temporary name of log file.
|
|
$logMode = "terminal"; # Default logging mode for logger.
|
|
|
|
|
|
# Configurables!!
|
|
#
|
|
$SENDMAIL = "/usr/lib/sendmail -t";
|
|
@errorMailRecipients = ( "philip.smart\@net2net.org" );
|
|
$errorMailFrom = "error\@localhost";
|
|
$errorMailSubject = "MZF Tool Errors...";
|
|
$PERL = "perl";
|
|
$PERLFLAGS = "";
|
|
|
|
|
|
##################################################################################
|
|
# GENERIC SUB-ROUTINES
|
|
##################################################################################
|
|
|
|
# Sub-routine to close the log file and email its contents to required participants.
|
|
#
|
|
sub logClose
|
|
{
|
|
# Locals.
|
|
local( $idx, $line, @mailRecipients, $mailFrom, $mailSubject, $mailHeader );
|
|
|
|
# No point closing log if one wasnt created!!
|
|
#
|
|
if($logName eq "" || $sendEmail == 0)
|
|
{
|
|
return;
|
|
}
|
|
|
|
# Back to beginning of file, to copy into email.
|
|
#
|
|
seek($logh, 0, 0);
|
|
|
|
# Build up an email to required recipients and send.
|
|
#
|
|
open(SENDMAIL, "|$SENDMAIL") or die "Cannot open $SENDMAIL: $!";
|
|
for($idx=0; $idx < @errorMailRecipients; $idx++)
|
|
{
|
|
print SENDMAIL "To: $errorMailRecipients[$idx]\n";
|
|
}
|
|
print SENDMAIL "Reply-to: $errorMailFrom\n";
|
|
print SENDMAIL "From: $errorMailFrom\n";
|
|
print SENDMAIL "Subject: $errorMailSubject\n";
|
|
print SENDMAIL "Content-type: text/plain\n\n";
|
|
while( $line = <$logh> )
|
|
{
|
|
chomp($line);
|
|
print SENDMAIL "$line\n";
|
|
}
|
|
close(SENDMAIL);
|
|
|
|
# Delete the logfile, not needed.
|
|
#
|
|
unlink($logName) or die "Couldn't unlink Error File $logName : $!";
|
|
}
|
|
|
|
# Function to write a message into a log file. The logfile is a temporary buffer, used
|
|
# to store all messages until program end. Upon completion, the buffer is emailed to required
|
|
# participants.
|
|
#
|
|
sub logWrite
|
|
{
|
|
# Get parameters, define locals.
|
|
local( $mode, $text ) = @_;
|
|
local( $date );
|
|
|
|
# Get current date and time for timestamping the log message.
|
|
#
|
|
$date = `date +'%Y.%m.%d %H:%M:%S'`;
|
|
chomp($date);
|
|
|
|
# In terminal mode (=interactive mode), always log to STDOUT.
|
|
#
|
|
if($logMode eq "terminal")
|
|
{
|
|
if(index($mode, "ND") == -1)
|
|
{
|
|
print "$date ";
|
|
}
|
|
print "$text";
|
|
if(index($mode, "NR") == -1)
|
|
{
|
|
print "\n";
|
|
}
|
|
|
|
# Die if required.
|
|
#
|
|
if (index($mode, 'die') != -1)
|
|
{
|
|
print "$date Terminating at program request.\n";
|
|
exit 1;
|
|
}
|
|
return;
|
|
}
|
|
|
|
# If the logfile hasnt been opened, open it.
|
|
#
|
|
if($logName eq "")
|
|
{
|
|
# Try new temporary filenames until we get one that doesnt already exist.
|
|
do {
|
|
$logName = tmpnam();
|
|
} until $logh = IO::File->new($logName, O_RDWR|O_CREAT|O_EXCL);
|
|
|
|
# Automatically flush out log.
|
|
$logh->autoflush(1);
|
|
|
|
# Only send email if we explicitly die.
|
|
#
|
|
$sendEmail = 0;
|
|
|
|
# Install an atexit-style handler so that when we exit or die,
|
|
# we automatically dispatch the log.
|
|
END { logClose($logh, $logName); }
|
|
}
|
|
|
|
# Print to log with date and time stamp.
|
|
#
|
|
print $logh "$date $text\n";
|
|
|
|
# Print to stdout for user view if in debug mode.
|
|
#
|
|
if($debugMode > 0)
|
|
{
|
|
print "$date $text\n";
|
|
}
|
|
|
|
# If requested, log termination message and abort program.
|
|
#
|
|
if (index($mode, 'die') != -1)
|
|
{
|
|
print $logh "$date Terminating at program request.\n";
|
|
$sendEmail = 1;
|
|
exit 1;
|
|
}
|
|
}
|
|
|
|
# Sub-routine to truncate whitespace at the front (left) of a string, returning the
|
|
# truncated string.
|
|
#
|
|
sub cutWhiteSpace
|
|
{
|
|
local( $srcString ) = @_;
|
|
local( $c, $dstString, $idx );
|
|
$dstString = "";
|
|
|
|
for($idx=0; $idx < length($srcString); $idx++)
|
|
{
|
|
# If the character is a space or tab, delete.
|
|
#
|
|
$c = substr($srcString, $idx, 1);
|
|
if(length($dstString) == 0)
|
|
{
|
|
if($c ne " " && $c ne "\t")
|
|
{
|
|
$dstString = $dstString . $c;
|
|
}
|
|
} else
|
|
{
|
|
$dstString = $dstString . $c;
|
|
}
|
|
}
|
|
return($dstString);
|
|
}
|
|
|
|
# Perl trim function to remove whitespace from the start and end of the string
|
|
#
|
|
sub trim($)
|
|
{
|
|
my $string = shift;
|
|
$string =~ s/^\s+//;
|
|
$string =~ s/\s+$//;
|
|
return $string;
|
|
}
|
|
|
|
# Left trim function to remove leading whitespace
|
|
#
|
|
sub ltrim($)
|
|
{
|
|
my $string = shift;
|
|
$string =~ s/^\s+//;
|
|
return $string;
|
|
}
|
|
|
|
# Right trim function to remove trailing whitespace
|
|
#
|
|
sub rtrim($)
|
|
{
|
|
my $string = shift;
|
|
$string =~ s/\s+$//;
|
|
return $string;
|
|
}
|
|
|
|
# Sub-routine to test if a string is empty, and if so, replace
|
|
# with an alternative string. The case of the returned string
|
|
# can be adjusted according to the $convertCase parameter.
|
|
#
|
|
sub trString
|
|
{
|
|
local( $tstString, $replaceString, $convertCase ) = @_;
|
|
local( $dstString );
|
|
|
|
$tstString=cutWhitespace($tstString);
|
|
$replaceString=cutWhitespace($replaceString);
|
|
if($tstString eq "")
|
|
{
|
|
$dstString = $replaceString;
|
|
} else
|
|
{
|
|
$dstString = $tstString;
|
|
}
|
|
|
|
# Convert to Lower Case?
|
|
#
|
|
if($convertCase == 1)
|
|
{
|
|
$dstString =~ lc($dstString);
|
|
}
|
|
# Convert to Upper Case?
|
|
#
|
|
elsif($convertCase == 2)
|
|
{
|
|
$dstString =~ uc($dstString);
|
|
}
|
|
return($dstString);
|
|
}
|
|
|
|
# Sub-routine to test if a numeric is empty, and if so, set to a
|
|
# given value.
|
|
#
|
|
sub trNumeric
|
|
{
|
|
local( $tstNumber, $replaceNumber ) = @_;
|
|
local( $dstNumber );
|
|
|
|
if(!defined($tstNumber) || $tstNumber eq "" || cutWhitespace($tstNumber) eq "")
|
|
{
|
|
$dstNumber = $replaceNumber;
|
|
} else
|
|
{
|
|
$dstNumber = $tstNumber;
|
|
}
|
|
|
|
return($dstNumber);
|
|
}
|
|
|
|
# Function to look at a string and decide wether its contents
|
|
# indicate Yes or No. If the subroutine cannot determine a Yes,
|
|
# then it defaults to No.
|
|
#
|
|
sub yesNo
|
|
{
|
|
local( $srcString ) = @_;
|
|
local( $dstString, $yesNo );
|
|
$yesNo = "N";
|
|
|
|
$dstString=lc(cutWhiteSpace($srcString));
|
|
if($dstString eq "y" || $dstString eq "yes" || $dstString eq "ye")
|
|
{
|
|
$yesNo = "Y";
|
|
}
|
|
return( $yesNo );
|
|
}
|
|
|
|
# Sub-routine to encrypt an input string, typically a password,
|
|
# using the Collateral Management Encrypt utility.
|
|
#
|
|
sub encrypt
|
|
{
|
|
local( $srcPasswd ) = @_;
|
|
local( $encPasswd );
|
|
$encPasswd="";
|
|
|
|
# Call external function to perform the encryption.
|
|
#
|
|
if($srcPasswd ne "")
|
|
{
|
|
$encPasswd=`$PROG_ENCRYPT -p $srcPasswd 2>&1`;
|
|
chomp($encPasswd);
|
|
}
|
|
return($encPasswd);
|
|
}
|
|
|
|
# Sub-routine to test if a string is empty, and if so, replace
|
|
# with an alternative string. The case of the returned string
|
|
# can be adjusted according to the $convertCase parameter.
|
|
#
|
|
sub testAndReplace
|
|
{
|
|
local( $tstString, $replaceString, $convertCase ) = @_;
|
|
local( $dstString );
|
|
#printf("Input:$tstString,$replaceString\n");
|
|
$tstString=cutWhiteSpace($tstString);
|
|
$replaceString=cutWhiteSpace($replaceString);
|
|
if($tstString eq "")
|
|
{
|
|
$dstString = $replaceString;
|
|
} else
|
|
{
|
|
$dstString = $tstString;
|
|
}
|
|
|
|
# Convert to Lower Case?
|
|
#
|
|
if($convertCase == 1)
|
|
{
|
|
$dstString =~ lc($dstString);
|
|
}
|
|
# Convert to Upper Case?
|
|
#
|
|
elsif($convertCase == 2)
|
|
{
|
|
$dstString =~ uc($dstString);
|
|
}
|
|
#printf("Output:$dstString:\n");
|
|
return($dstString);
|
|
}
|
|
|
|
# Subroutine to generate a unique name by adding 2 digits onto the end of it. A hash of existing
|
|
# names is given to compare the new value against.
|
|
#
|
|
sub getUniqueName
|
|
{
|
|
local( $cnt, $uniqueName ) = ( 0, "" );
|
|
local( $startName, $maxLen, $usedNames ) = @_;
|
|
|
|
# Go through looping, adding a unique number onto the end of the string, then looking it
|
|
# up to see if it already exists.
|
|
#
|
|
$uniqueName = substr($startName, 0, $maxLen);
|
|
while(defined($$usedNames{$uniqueName}))
|
|
{
|
|
$uniqueName = substr($uniqueName, 0, $maxLen-2) . sprintf("%02d", $cnt);
|
|
$cnt++;
|
|
if($cnt > 99)
|
|
{
|
|
logWrite("die", "Unique identifier > 99: $uniqueName");
|
|
}
|
|
}
|
|
|
|
# Return unique name.
|
|
#
|
|
return($uniqueName);
|
|
}
|
|
|
|
# Sub-routine to process command line arguments. New style POSIX argument format used.
|
|
#
|
|
sub argOptions
|
|
{
|
|
local ( $writeUsage, $msg, $exitCode ) = @_;
|
|
|
|
if( $writeUsage == 1 )
|
|
{
|
|
print STDOUT "Usage: $PROGNAME <commands> [<options>] \n";
|
|
print STDOUT " commands= --help |\n";
|
|
print STDOUT " --verbose |\n";
|
|
print STDOUT " --command=<IDENT|ADDHEADER|DELHEADER> |\n";
|
|
print STDOUT " --mzffile=<file> {IDENT|ADDHEADER|DELHEADER} |\n";
|
|
print STDOUT " --srcfile=<file> {ADDHEADER} |\n";
|
|
print STDOUT " --dstfile=<file> {DELHEADER} |\n";
|
|
print STDOUT " --filename=<name of tape file> (ADDHEADER} |\n";
|
|
print STDOUT " --loadaddr=<addr tape should load @> (ADDHEADER} |\n";
|
|
print STDOUT " --execaddr=<auto exec addr> (ADDHEADER} |\n";
|
|
print STDOUT " --tapetype=<1 byte type value> (ADDHEADER} |\n";
|
|
print STDOUT " --comment=<comment string> (ADDHEADER} |\n";
|
|
print STDOUT " options = --debug=<1=ON, 0=OFF>\n";
|
|
print STDOUT "\n";
|
|
}
|
|
if($msg ne "")
|
|
{
|
|
print STDOUT "Error: $msg\n";
|
|
}
|
|
exit( $exitCode );
|
|
}
|
|
|
|
|
|
##################################################################################
|
|
# END OF GENERIC SUB-ROUTINES
|
|
##################################################################################
|
|
|
|
|
|
##################################################################################
|
|
#
|
|
# MAIN PROGRAM
|
|
#
|
|
##################################################################################
|
|
|
|
# Locals.
|
|
#
|
|
local( $time, $date, $mzfExists, $a_mromExists, $b_mromExists, $k_mromExists, $m7_mromExists, $m8_mromExists, $m12_mromExists, $m20_mromExists,
|
|
$a_80c_mromExists, $b_80c_mromExists, $k_80c_mromExists, $m7_80c_mromExists, $m8_80c_mromExists, $m12_80c_mromExists, $m20_80c_mromExists,
|
|
$mzf_type, $mzf_filename, $mzf_size, $mzf_loadaddr, $mzf_execaddr, $mzf_comment);
|
|
|
|
# Get current time and date.
|
|
#
|
|
$time = `date +'%H:%M:%S'`;
|
|
$date = `date +'%d.%m.%Y'`;
|
|
chomp($time);
|
|
chomp($date);
|
|
|
|
# Sign-on.
|
|
#
|
|
print STDOUT "$TITLE (v$VERSION) \@ ${VERSIONDATE}\n\n";
|
|
|
|
# Parse arguments and put into required variables.
|
|
#
|
|
$verbose = 0;
|
|
$fileName = "";
|
|
$s_loadAddr = "";
|
|
$s_execAddr = "";
|
|
$s_tapeType = "";
|
|
$comment = "";
|
|
GetOptions( "debug=n" => \$debugMode, # Debug Mode?
|
|
"verbose" => \$verbose, # Show details?
|
|
"mzffile=s" => \$mzfFile, # MZF file.
|
|
"dstfile=s" => \$dstFile, # Destination file (for header removal).
|
|
"srcfile=s" => \$srcFile, # Source file (for header adding).
|
|
"filename=s" => \$fileName, # Filename to insert into header.
|
|
"loadaddr=s" => \$s_loadAddr, # Tape load address.
|
|
"execaddr=s" => \$s_execAddr, # Tape execution address.
|
|
"tapetype=s" => \$s_tapeType, # Tape type (ie. 01 = Machine Code).
|
|
"comment=s" => \$comment, # Tape comment string.
|
|
"command=s" => \$command, # Command to execute.
|
|
"help" => \$help, # Help required on commands/options?
|
|
);
|
|
|
|
# Help required?
|
|
#
|
|
if(defined($help))
|
|
{
|
|
argOptions(1, "");
|
|
}
|
|
|
|
# Convert number arguments from string to decimal.
|
|
#
|
|
if($s_loadAddr ne "")
|
|
{
|
|
$loadAddr = oct($s_loadAddr);
|
|
}
|
|
if($s_execAddr ne "")
|
|
{
|
|
$execAddr = oct($s_execAddr);
|
|
}
|
|
if($s_tapeType ne "")
|
|
{
|
|
$tapeType = oct($s_tapeType);
|
|
}
|
|
|
|
# Verify command.
|
|
#
|
|
if($command eq "IDENT" || $command eq "ADDHEADER" || $command eq "DELHEADER")
|
|
{
|
|
1;
|
|
}
|
|
else
|
|
{
|
|
argOptions(1, "Illegal command given on command line:$command.\n",$ERR_BADARGUMENTS);
|
|
}
|
|
|
|
# Check that the additional parameters have been provided for the ADDHEADER command.
|
|
if($command eq "ADDHEADER" && ($fileName eq "" || !defined($loadAddr) || !defined($execAddr) || !defined($tapeType)) )
|
|
{
|
|
argOptions(3, "ADDHEADER command requires the following parameters to be provided: --filename, --loadaddr, --execaddr, --tapetype\n",$ERR_BADARGUMENTS);
|
|
}
|
|
|
|
# For ident or delete header commands, we need to open and read the mzf file.
|
|
#
|
|
if(($command eq "IDENT" || $command eq "DELHEADER") && defined($mzfFile) && $mzfFile ne "")
|
|
{
|
|
# If defined, can we open it?
|
|
#
|
|
if( ! open(MZFFILE, "<".$mzfFile) )
|
|
{
|
|
argOptions(1, "Cannot open MZF file: $mzfFile.\n",$ERR_BADFILENAME);
|
|
}
|
|
|
|
@MZF = ();
|
|
binmode(MZFFILE);
|
|
local $/ = \1;
|
|
$cnt = 0;
|
|
$skip = 0;
|
|
while ( my $byte = <MZFFILE> )
|
|
{
|
|
$MZF[$cnt] = $byte;
|
|
$cnt++;
|
|
}
|
|
$MZF_SIZE = $cnt;
|
|
|
|
# Once the MZF is in memory, analyse the details and output.
|
|
#
|
|
$mzf_header = pack('a'x128, @MZF);
|
|
($mzf_type, $mzf_filename, $mzf_size, $mzf_loadaddr, $mzf_execaddr, $mzf_comment) = unpack 'c1 a17 v4 v4 v4 a104', $mzf_header;
|
|
$mzf_filename =~ s/\r|\n//g;
|
|
|
|
# Output detail if requested.
|
|
#
|
|
if($verbose)
|
|
{
|
|
printf STDOUT "File Name : %s\n", $mzf_filename;
|
|
printf STDOUT "File Type : %02x\n", $mzf_type;
|
|
printf STDOUT "File Size : %04x\n", $mzf_size;
|
|
printf STDOUT "File Load Address : %04x\n", $mzf_loadaddr;
|
|
printf STDOUT "File Exec Address : %04x\n", $mzf_execaddr;
|
|
printf STDOUT "Comment : %s\n", $mzf_comment;
|
|
}
|
|
|
|
# For the DELHEADER command, a destination needs to be provided and opened.
|
|
if($command eq "DELHEADER" && defined($dstFile) && $dstFile ne "")
|
|
{
|
|
if( ! open(DSTFILE, ">".$dstFile) )
|
|
{
|
|
argOptions(1, "Cannot open the destination file: $dstFile.\n",$ERR_BADFILENAME);
|
|
}
|
|
}
|
|
}
|
|
elsif($command eq "ADDHEADER" && defined($mzfFile) && $mzfFile ne "")
|
|
{
|
|
# If defined, can we create it?
|
|
#
|
|
if( ! open(MZFFILE, ">".$mzfFile) )
|
|
{
|
|
argOptions(1, "Cannot create MZF file: $mzfFile.\n",$ERR_BADFILENAME);
|
|
}
|
|
|
|
# For this command, a source file needs to exist and opened.
|
|
if(defined($srcFile) && $srcFile ne "")
|
|
{
|
|
if( ! open(SRCFILE, "<".$srcFile) )
|
|
{
|
|
argOptions(1, "Cannot open the source file: $srcFile.\n",$ERR_BADFILENAME);
|
|
}
|
|
|
|
@SRC = ();
|
|
binmode(SRCFILE);
|
|
local $/ = \1;
|
|
$cnt = 0;
|
|
$skip = 0;
|
|
while ( my $byte = <SRCFILE> )
|
|
{
|
|
$SRC[$cnt] = $byte;
|
|
$cnt++;
|
|
}
|
|
$SRC_SIZE = $cnt;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
argOptions(2, "No MZF file given, use --mzffile=<file>.\n");
|
|
}
|
|
|
|
# Process command as necessary.
|
|
#
|
|
if($command eq "ADDHEADER")
|
|
{
|
|
# Build the header based on given information and size of src file.
|
|
$mzf_size = scalar @SRC;
|
|
$mzf_type = $tapeType; # For exit code.
|
|
$mzf_header = pack('c1 a17 v v v', $tapeType, $fileName, $mzf_size, $loadAddr, $execAddr);
|
|
$mzf_header .= pack('a104', $comment) ;
|
|
|
|
# Store in file.
|
|
print MZFFILE $mzf_header;
|
|
|
|
# Now add the source data.
|
|
foreach my $byte (@SRC) { print MZFFILE $byte; }
|
|
|
|
# All done.
|
|
close MZFFILE;
|
|
|
|
# Output detail if requested.
|
|
#
|
|
if($verbose)
|
|
{
|
|
printf STDOUT "File Name : %s\n", $fileName;
|
|
printf STDOUT "File Type : %02x\n", $tapeType;
|
|
printf STDOUT "File Size : %04x\n", $mzf_size;
|
|
printf STDOUT "File Load Address : %04x\n", $loadAddr;
|
|
printf STDOUT "File Exec Address : %04x\n", $execAddr;
|
|
printf STDOUT "Comment : %s\n", $comment;
|
|
}
|
|
}
|
|
# For delete, simply write out the tape contents less the header (first 128 bytes).
|
|
elsif($command eq "DELHEADER")
|
|
{
|
|
my $cnt = 0;
|
|
foreach my $byte (@MZF) { if($cnt++ >= 128) { print DSTFILE $byte; } }
|
|
close DSTFILE;
|
|
}
|
|
|
|
# Exit code is the type of MZF file.
|
|
exit $mzf_type;
|