/*
 * MountDiskArchive.rexx -- Mount ADF/ADZ/DMS archives as Disk.
 *
 * Copyright (C) 1998,99 Thomas Aglassinger <agi@sbox.tu-graz.ac.at>.
 * All rights reserved. Freeware. Use at your own risk.
 *
 *--------------------------------------------------------------------------
 *
 * Usage: rx MountDiskArchive File/A,Drive,Quiet/S,Debug/S
 *
 * File  - ADF/ADZ or DMS file to mount
 * Drive - Target drive where to mount. If ommited, a new FMS device is
 *    created and used as target
 * Quiet - Disable status messages
 * Debug - Enable debug log. It is stored in t:MountDiskArchive.log
 */

version_info = "$VER: MountDiskArchive.rexx 1.2 (4.1.99)"

/* Setup argument variables */
template = "File/A,Drive,Quiet/S,Debug/S"
quiet = 0
debug = 0
drive = ''
file = ''

log_filename = 't:MountDiskArchive.log'

lf = d2c(10)
Parse Var version_info . '(' version_date ')'

/* Clear logfile and write version information to it */
If Open('log', log_filename, 'write') then do
   Close('log')
end
Call append_log_line(version_info)

Signal On NoValue
Signal On Failure
Signal On Syntax

/* Open and add required libraries */
Call open_library('rexxdossupport.library', 0, -30, 2)
Call open_library('rexxsupport.library', 0, -30, 0)

/* Parse, extract and check CLI arguments */
Parse Arg arguments
Call check_arguments(arguments)

/* Examine archive type and check requirements
 *
 * These things are already done here so that user mistakes or damaged
 * archives do not cause orphaned FMS devices to be created. */
Call examine_filetype()
Call check_requirements()

/* If no drive was specified, dynamically mount a new one and use
 * it as target */
if drive_name = '' then do
   drive_name = mount_new_drive()
end

/* Check if device exists */
if ~drive_exists(drive_name) then do
    exit_error('Drive "' || drive_name || '" not mounted', 10)
end

/* Extract archive */
Call append_log_heading('Extract')
Call status_message('Extract "' || archive_name || '" to "' ,
                    || drive_name || '"')
select
   when filetype = 'ADF' then do
      unpack_command = 'TransADF Write ' || drive_name || ' ' || archive_name
   end
   when filetype = 'DMS' then do
      unpack_command = 'dms <nil: Write ' || archive_name || ' To ' ,
                       || drive_name || ' NoText'
   end
   otherwise do
      Signal Bug /* Invalid filetype */
   end
end
address_command(0, unpack_command)

/* Remove log file because everything worked */
if ~debug then do
   Delete(log_filename)
end

exit 0

/* ----------------------------------------------------------------------
 * Subroutines
 * ---------------------------------------------------------------------- */

/* Examine file type of archive. For unknown types or no archive, exit
 * with error message */
examine_filetype:
   filetype = ''

   /* Examine file id */
   if Open('archive', archive_name, 'read') then do
      fileid = ReadCh('archive', 4)
      Call append_log_line('fileid ="' || fileid || '"')
      if fileid = 'DMS!' then do
         filetype = 'DMS'
      end
      Close('archive')
   end
   else do
      exit_error('Can not open archive "' || archive_name || '" for input', 10)
   end

   /* Examine suffix */
   if filetype = '' then do
      Parse Upper Value Reverse(archive_name) With suffix '.' .
      suffix = Reverse(suffix)
      Call append_log_line('suffix ="' || suffix || '"')
      if Find("ADF ADZ", suffix) > 0 then do
         filetype = 'ADF'
      end
   end

   if filetype = '' then do
      exit_error('The archive type of "' || archive_name || '" ' ,
                 || 'is not supported or the archive is damaged' || lf ,
                 || 'Allowed archives are: ADF, ADZ and DMS', 10)
   end

   Return

/* Check required material to be installed, exit with error message if not */
check_requirements:
   Call append_log_heading('Requirements')
   if filetype = 'ADF' then do
      Call check_program_exists('TransADF', 4, 'aminet:disk/misc/TransADF.lha')
   end
   else if filetype = 'DMS' then do
      Call check_program_exists('dms', 0, 'aminet:util/arc/dms111.run')
   end
   if ~exists('devs:fmsdisk.device') then do
      exit_error('The "fmsdisk.device" must be installed in "devs:"' ,
                 || obtain_message('aminet:disk/misc/fmsdisk.lha'), 10)
   end
   if ~exists('fms:') then do
      exit_error('The assign "fms:" does not exist' || lf ,
                 || 'Refer to the FMS manual for more details', 10)
   end

   Return

/* Check, if a device or assign exists */
drive_exists: procedure
   Parse Upper Arg drive_name ':'

   drive_exists = ShowList('Handler', drive_name) | ,
                  ShowList('Volume', drive_name) | ,
                  ShowList('Assign', drive_name)

   Return drive_exists

/* Find an unused FMS device and mount it */
mount_new_drive:

   /* Attempt to open a public message port acting as semaphore. If this port
    * can not be opened, another instance of this script running must have
    * opened it before.
    *
    * This prevents two scripts running at the same time from
    * attempting to mount the same device, which would cause a difficult to
    * understand error message when excuting c:mount. */
   semaphore_portname = 'MountDiskArchive.semaphore'
   If ~OpenPort(semaphore_portname) then do
      exit_error('Another instance of this script is already attempting to ' ,
                 || 'mount a new FMS drive' || lf ,
                 || 'Wait until it is finished, then try again', 10)
   end

   /* Search for an unused FMS drive */
   new_drive_unit = -1
   unused_device_found = 0

   do until unused_device_found
      new_drive_unit = new_drive_unit + 1
      new_drive_name = 'ff' || new_drive_unit || ':'
      unused_device_found = ~drive_exists(new_drive_name)
   end

   Call status_message('Mount "' || new_drive_name || '"')

   /* Create mountlist entry for new new_drive_name */
   mount_entry = '/* $VER: ff' || new_drive_unit ,
      || ' 37.0 (' || version_date || ') */' || lf ,
      || new_drive_name || lf ,
      || '   Device         = fmsdisk.device' || lf ,
      || '   Unit           = ' || new_drive_unit || lf ,
      || '   Flags          = 1'  || lf ,
      || '   Surfaces       = 2'  || lf ,
      || '   BlocksPerTrack = 11' || lf ,
      || '   Reserved       = 2'  || lf ,
      || '   Interleave     = 0'  || lf ,
      || '   LowCyl         = 0'  || lf ,
      || '   HighCyl        = 79' || lf ,
      || '   Buffers        = 2'  || lf ,
      || '   BufMemType     = 0'  || lf ,
      || '#' || lf
   Call append_log_heading('Mount entry')
   Call append_log_line(mount_entry)

   /* Write temporary mountlist */
   mount_filename = 't:Mountlist.ff' || new_drive_unit
   if Open('mount_file', mount_filename, 'write') then do
      WriteCh('mount_file', mount_entry)
      Close('mount_file')
   end
   else do
      exit_error('could not write "' || mount_filename || '"', 20)
   end

   /* Mount it */
   Call append_log_heading('Mount ' || new_drive_name)
   address_command(0, 'c:mount ' || new_drive_name || ' from ' || mount_filename)

   /* Delete temporary file */
   if ~debug then do
      Delete(mount_filename)
   end

   /* Close semaphore port */
   ClosePort(semaphore_portname)

   Return new_drive_name

/* Check Arguments */
check_arguments:
   Parse Arg arguments

   If Strip(arguments, 'B', ' "') = '?' then do
      WriteCh('STDOUT', template || ': ')
      Pull arguments
   end

   if ReadArgs(arguments, template) then do
      archive_name = file
      drive_name = drive
   end
   else do
      Call exit_error("Error in arguments: " || Fault(RC), 10)
   end

   Call append_log_heading('Arguments')
   Call append_log_line('archive="' || archive_name || '"')
   Call append_log_line('drive  ="' || drive_name || '"')
   Call append_log_line('quiet  = ' || quiet)
   Call append_log_line('debug  = ' || debug)

   /* Check for drive name ending in ":" */
   if drive ~= '' then do
      if Right(drive_name, 1) ~= ':' then do
         exit_error('Drive "' || drive_name || ,
                    '" does not end with colon (:)', 10)
      end
   end

   Return

/* Execute CLI command */
address_command:
   Parse Arg maximum_rc, cli_command

   Call append_log_line('COMMAND: «' || cli_command || '»')

   Options FailAt maximum_rc + 1
   Address Command cli_command || ' >>' || log_filename

   Return RC

/* View status message */
status_message: procedure expose quiet
   Parse Arg message
   if ~quiet then do
      Say message
   end
   Return

/* ----------------------------------------------------------------------
 * Error handling and logfile functions
 * ---------------------------------------------------------------------- */

/* Append line to logfile */
append_log_line:
   Parse Arg line
   If Open('log', log_filename, 'append') then do
      WriteLn('log', line)
      Close('log')
   end
   else do
      Call exit_error('Can not write to logfile "' || log_filename || '"', 20)
   end

   Return

/* Append heading to log */
append_log_heading:
   Parse Arg heading
   Call append_log_line(Copies('-', 70) || lf || ,
                      heading || lf || ,
                      Copies('-', 70))
   Return

/* Exit with error message */
exit_error: procedure expose exit_code
   Parse Arg message, exit_code
   Say message
   Exit exit_code

/* Create a text to describe where to obtain a certain item from */
obtain_message: procedure
   Parse Arg obtain_from

   if obtain_from = '' then do
      message = ''
   end
   else do
      message = d2c(10) || 'It can be obtained from ' || obtain_from
   end

   Return message

/* Open a library */
open_library:
   Parse Arg name, priority, offset, version, obtain_from

   lookup_name = name
   if Pos(':/', name) = 0 then do
      lookup_name = 'libs:' || name
   end

   if exists('libs:' || name) then do
      AddLib(name, priority, offset, version)
   end
   else do
      exit_error('Library not found: "' || lookup_name || ,
                 '", version ' || version || ,
                 obtain_message(obtain_from), 10)
   end

   Return

/* Check if a program with a minimum version number is installed */
check_program_exists:
   Parse Arg name, version, obtain_from

   Call append_log_line('check program "' || name || '" (' || version || '); "' || obtain_from || '"')

   message = ''
   if address_command(5, 'which ' || name) > 0 then do
      message = 'The program "' || name || '" must be installed within the search path (e.g. in "c:")'
   end

   if (message = '') & (version > 0) then do
      if address_command(5, 'version `which ' || name ,
                         || '` ' || version ) > 0 ,
      then do
         message = 'The installed version of "' || name || '" is outdated,' ,
                   'required version is ' || version
      end
   end

   if message ~= '' then do
      exit_error(message || obtain_message(obtain_from), 10)
   end

   Return

/* ----------------------------------------------------------------------
 * Signal Handlers
 * ---------------------------------------------------------------------- */

/* Signal handler for accessing unitialized variables */
NoValue:
   Signal Off NoValue
   message = lf || SIGL SourceLine(SIGL) || lf || ,
             'uninitialized value in line ' || SIGL
   if debug then do
      Say message
      Exit 20
   end
   else do
      Call append_log_heading(message)
      Signal Bug /* NoValue */
   end

/* Signal handler for syntax errors */
Syntax:
   Signal Off Syntax
   message = lf || SIGL SourceLine(SIGL) || lf || ,
             'syntax error in line ' || SIGL
   if debug then do
      Say message
      Exit 20
   end
   else do
      Call append_log_heading(message)
      Signal Bug /* Syntax */
   end

/* Signal handler for failed CLI commands. This should only happen in
 * address_command, thus cli_command is used to determine the name. */
Failure:
   Signal Off Failure

   /* For return codes beyond 10, the Shell already displays a
    * message which command failed, so this is not repeated. */
   if RC <= 10 then do
      Say Word(cli_command, 1) || '" failed with returncode ' || RC */
   end

   Exit RC

/* Signal handler for bugs */
Bug:
   message = 'Bug in line ' || SIGL || ': ' SourceLine(SIGL)
   Call append_log_heading(message)

   if debug then do
      Say
      Say message
   end
   else do
      Say
      Say 'You just encountered a bug in this script.'
      Say
      Say 'An automatic bug report has been written to "' || log_filename || '"'
      Say 'Please send this file to <agi@sbox.tu-graz.ac.at> so the problem'
      Say 'can be fixed.'
      Say
   end

   Exit 20