Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) (07/16/90)
Submitted-by: rich@californium.cchem.berkeley.ed (Rich Mazzarisi)
Posting-number: Volume 90, Issue 210
Archive-name: util/icontools/part01
[ see comp.binaries.amiga for the binaries to icontools ...tad ]
[ file arp/ArpBase.j was split for posting ]
Here are two programs to manage some aspects of icons though the use of
the Workbench. One is FloatIcon to allow the Workbench to freely place an
icon in a drawer window. The other is ReplaceTool to set a new default
tool for project icons solely using the Workbench icons or the arp file
requester. Included is the source in JForth along with the beginnings of
arp support for JForth.
Rich Mazzarisi
#!/bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 1 (of 2)."
# Contents: README arp arp/ArpBase.j.ab arp/arp_support source
# source/FloatIcon.f source/ReplaceTool.f
# Wrapped by tadguy@xanth on Sun Jul 15 18:36:25 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'README'\"
else
echo shar: Extracting \"'README'\" \(4208 characters\)
sed "s/^X//" >'README' <<'END_OF_FILE'
X 5/20/90
X
X << IconTools >>
X by Richard Mazzarisi
X written in Jforth Professional 2.0
X
X Introduction:
X
X These programs are two tools for managing icons under the
X Workbench, namely ReplaceTool and FloatIcon. They have been done
X before, but I have never seen such tools that worked totally as an
X Workbench based operation. So I decided to write them.
X
X They are self documenting; just double click the icon to see the
X instructions.
X
X These programs not public domain but are freely distributable as
X long as they are distributed with this notice and only a nominal fee
X is charged for the disks to cover the cost of distribution. They may
X be included in Fred Fish's collection and in Delta Research's JGoodies
X disks.
X
X (NOTE: The author assumes no responsibility for any damages
X resulting from the use of these programs.)
X
X
X ReplaceTool 2.02:
X
X ReplaceTool allows you to change the default tool of any number
X of project icons all at once. This is useful when installing a
X program and some projects created by it onto a disk which will have a
X different path from that of the distribution disk. Usually double
X clicking the project icon would result in a program not found error.
X Then you had to type the new path into each icon using "info" from the
X Workbench menu, one by one! Now instead you can just click on
X ReplaceTool and shift click on all the project icons and the tool to be
X used. That tool's path and name will be placed in the DefaultTool
X slot of the icon.
X
X And how about all those README files whose icons all have some
X text file browser in a subdirectory of the original disk as their
X default tool; less has no icon, you say. Well, there is a second way
X to use ReplaceTool. If you shift click ONLY on project icons,
X ReplaceTool will open the ARP file requester with which you can
X specify the tool and its path. The default directory will be SYS:, and
X of course you may click the buttons and names to get the path and tool
X you desire. Or you may type the path and name into the string
X requesters. You may type ANY path or name into the requesters
X regardless of what is shown in the window; so that a relative path is
X possible such as "/" to use a tool one directory up from where the
X project lives, ":<path>" to indicate the current disk, or blank it out
X entirely to indicate the same directory. You just type the
X appropriate path into the drawer string requester AFTER getting the
X correct file name to show in the file string requester.
X
X For the use of the second option, naturally you must have the
X arp.library (version 39 or greater) installed in your LIBS: directory.
X
X NOTE: Due to the behavior of the Workbench 1.3 the change of the
X default tool does not take effect until the icons are reread from the
X disk. So it is necessary to close the drawers involved and to reopen
X them before using the modified projects. (Under version 2.0 there
X will be a menu item to reread the disk.)
X
X
X FloatIcon 1.03:
X
X FloatIcon is a spinoff of Replacetool, basically it was practice
X at accessing the icon info and writing it back. It simply lets you
X make an icon free floating again after it has been "Snapshot". This
X means that the Workbench will decide where it should be placed when a
X drawer is opened rather than putting it at a fixed position.
X
X Having the icons free floating seems to work better with Dave
X Navas' JazzBench since it does a more intelligent job of icon
X placement than the Workbench, so that the names don't overlap.
X (AmigaDos 2.0 does a better job at this than 1.3)
X
X
X Compiling the programs:
X
X In order to recompile these programs you need the Jforth
X Professional 2.0 Amiga developement package. Assign JARP: to the
X directory where the arp header file and support file may be found.
X
X
X Richard Mazzarisi
X 891 Post St. #207
X San Francisco, CA
X 94109
X
X email:
X rich@californium.cchem.berkeley.edu
X rmazz@hydrogen.cchem.berkeley.edu
X nmr@garnet.berkeley.edu
X
END_OF_FILE
if test 4208 -ne `wc -c <'README'`; then
echo shar: \"'README'\" unpacked with wrong size!
fi
# end of 'README'
fi
if test ! -d 'arp' ; then
echo shar: Creating directory \"'arp'\"
mkdir 'arp'
fi
if test -f 'arp/ArpBase.j.ab' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'arp/ArpBase.j.ab'\"
else
echo shar: Extracting \"'arp/ArpBase.j.ab'\" \(20065 characters\)
sed "s/^X//" >'arp/ArpBase.j.ab' <<'END_OF_FILE'
X3 constant PRB_INTERACTIVE ( Run an interactive shell )
X7 constant PRB_FB ( Alt function bit... )
X
X1 PRB_CLI << constant PRF_CLI
X1 PRB_BACKGROUND << constant PRF_BACKGROUND
X1 PRB_EXECUTE << constant PRF_EXECUTE
X1 PRB_INTERACTIVE << constant PRF_INTERACTIVE
X1 PRB_FB << constant PRF_FB
X
X( )
X( ************************************************************************)
X( * Common values for sh_Control which allow you to do usefull *)
X( * and somewhat "standard" things... *)
X( ************************************************************************)
X( )
XPRF_FB PRF_INTERACTIVE | constant INTERACTIVE_SHELL ( Gimme a newshell! )
XPRF_FB PRF_INTERACTIVE | PRF_CLI | constant INTERACTIVE_CLI ( Gimme that ol newcli! )
XPRF_FB PRF_BACKGROUND | constant BACKGROUND_SHELL ( gimme a background shell )
XPRF_FB PRF_BACKGROUND | PRF_EXECUTE | constant EXECUTE_ME ( aptly named, doncha think? )
X
X( )
X( ************************************************************************)
X( * Additional IoErr[] returns added by ARP... *)
X( ************************************************************************)
X( )
X303 constant ERROR_BUFFER_OVERFLOW ( User or internal buffer overflow )
X304 constant ERROR_BREAK ( A break character was received )
X305 constant ERROR_NOT_EXECUTABLE ( A file has E bit cleared )
X400 constant ERROR_NOT_CLI ( Program/function neeeds to be cli )
X
X( )
X( ************************************************************************)
X( * Resident Program Support *)
X( ************************************************************************)
X( * This is the kind of node allocated for you when you AddResidentPrg[] *)
X( * a code segment. They are stored as a single linked list with the *)
X( * root in ArpBase. If you absolutely *must* wander through this list *)
X( * instead of using the supplied functions, then you must first obtain *)
X( * the semaphore which protects this list, and then release it *)
X( * afterwards. Do not use Forbid[] and Permit[] to gain exclusive *)
X( * access! Note that the supplied functions handle this locking *)
X( * protocol for you. *)
X( ************************************************************************)
X( )
X
X:STRUCT ResidentProgramNode
X APTR rpn_Next ( next or NULL )
X LONG rpn_Usage ( Number of current users )
X USHORT rpn_AccessCnt ( Total times used... )
X ULONG rpn_CheckSum ( Checksum of code )
X LONG rpn_Segment ( Actual segment )
X USHORT rpn_Flags ( See definitions below... )
X ( %?) 1 BYTES rpn_Name ( Allocated as needed )
X ;STRUCT
X
X
X( )
X( ************************************************************************)
X( * Bit definitions for rpn_Flags.... *)
X( ************************************************************************)
X( )
X0 constant RPNB_NOCHECK ( Set in rpn_Flags for no checksumming... )
X1 constant RPNB_CACHE ( Private usage in v1.3... )
X
X1 RPNB_NOCHECK << constant RPNF_NOCHECK
X1 RPNB_CACHE << constant RPNF_CACHE
X
X( )
X( ************************************************************************)
X( * If your program starts with this structure, ASyncRun[] and SyncRun[] *)
X( * will override a users stack request with the value in rpt_StackSize. *)
X( * Furthermore, if you are actually attached to the resident list, a *)
X( * memory block of size rpt_DataSize will be allocated for you, and *)
X( * a pointer to this data passed to you in register A4. You may use *)
X( * this block to clone the data segment of programs, thus resulting in *)
X( * one copy of text, but multiple copies of data/bss for each process *)
X( * invocation. If you are resident, your program will start at *)
X( * rpt_Instruction, otherwise, it will be launched from the initial *)
X( * branch. *)
X( ************************************************************************)
X( )
X
X:STRUCT ResidentProgramTag
X LONG rpt_NextSeg ( Provided by DOS at LoadSeg time )
X( )
X( ************************************************************************)
X( * The initial branch destination and rpt_Instruction do not have to be *)
X( * the same. This allows different actions to be taken if you are *)
X( * diskloaded or resident. DataSize memory will be allocated only if *)
X( * you are resident, but StackSize will override all user stack *)
X( * requests. *)
X( ************************************************************************)
X( )
X USHORT rpt_BRA ( Short branch to executable )
X USHORT rpt_Magic ( Resident majik value )
X ULONG rpt_StackSize ( min stack for this process )
X ULONG rpt_DataSize ( Data size to allocate if resident )
X ( rpt_Instruction; Start here if resident )
X ;STRUCT
X
X
X( )
X( ************************************************************************)
X( * The form of the ARP allocated node in your tasks memlist when *)
X( * launched as a resident program. Note that the data portion of the *)
X( * node will only exist if you have specified a nonzero value for *)
X( * rpt_DataSize. Note also that this structure is READ ONLY, modify *)
X( * values in this at your own risk. The stack stuff is for tracking, *)
X( * if you need actual addresses or stack size, check the normal places *)
X( * for it in your process/task struct. *)
X( ************************************************************************)
X( )
X
X:STRUCT ProcessMemory
X STRUCT Node pm_Node
X USHORT pm_Num ( This is 1 if no data, two if data )
X\ %? correct below? -RM CPTR pm_Stack;
X APTR pm_Stack
X ULONG pm_StackSize
X\ %? correct below? -RM CPTR pm_Data; /* Only here if pm_Num == 2 */
X APTR pm_Data ( Only here if pm_Num == 2 )
X ULONG pm_DataSize
X ;STRUCT
X
X
X( )
X( ************************************************************************)
X( * To find the above on your memlist, search for the following name. *)
X( * We guarantee this will be the only arp.library allocated node on *)
X( * your memlist with this name. *)
X( * i.e. FindName[task->tcb_MemEntry, PMEM_NAME]; *)
X( ************************************************************************)
X( )
X0" ARP_MEM" 0string PMEM_NAME
X
X$ 4AFC constant RESIDENT_MAGIC ( same as RTC_MATCHWORD [trapf] )
X
X( )
X( ************************************************************************)
X( * Date String/Data structures *)
X( ************************************************************************)
X( )
X
X:STRUCT DateTime
X STRUCT DateStamp dat_Stamp ( DOS Datestamp )
X UBYTE dat_Format ( controls appearance ot dat_StrDate )
X UBYTE dat_Flags ( See BITDEF's below )
X APTR dat_StrDay ( day of the week string )
X APTR dat_StrDate ( date string )
X APTR dat_StrTime ( time string )
X ;STRUCT
X
X
X( )
X( ************************************************************************)
X( * Size of buffer you need for each DateTime strings: *)
X( ************************************************************************)
X( )
X10 constant LEN_DATSTRING
X
X( )
X( ************************************************************************)
X( * For dat_Flags *)
X( ************************************************************************)
X( )
X0 constant DTB_SUBST ( Substitute "Today" "Tomorrow" where appropriate )
X1 constant DTB_FUTURE ( Day of the week is in future )
X
X1 DTB_SUBST << constant DTF_SUBST
X1 DTB_FUTURE << constant DTF_FUTURE
X
X( )
X( ************************************************************************)
X( * For dat_Format *)
X( ************************************************************************)
X( )
X0 constant FORMAT_DOS ( dd-mmm-yy AmigaDOS's own, unique style )
X1 constant FORMAT_INT ( yy-mm-dd International format )
X2 constant FORMAT_USA ( mm-dd-yy The good'ol'USA. )
X3 constant FORMAT_CDN ( dd-mm-yy Our brothers and sisters to the north )
XFORMAT_CDN constant FORMAT_MAX ( Larger than this? Defaults to AmigaDOS )
X
X( )
X( ************************************************************************)
X( * This prototype is here to prevent the possible error in defining *)
X( * IoErr[] as LONG and thus causing LastTracker to give you trash... *)
X( * *)
X( * N O T E ! You MUST! have IoErr[] defined as LONG to use LastTracker *)
X( * If your compiler has other defines for this, you may wish *)
X( * to move the prototype for IoErr[] into the DO_ARP_COPIES *)
X( ************************************************************************)
X( )
X\ %? LONG IoErr ARGs( (VOID) );
X
X\ %? /*
X
X\ %? * These duplicate the calls in dos.library *
X\ %? * Only include if you can use arp.library without dos.library *
X
X\ %? */
X\ %? #ifdef DO_ARP_COPIES
X\ %? BPTR Open ARGs( (char *, LONG) );
X\ %? VOID Close ARGs( (BPTR) );
X\ %? LONG Read ARGs( (BPTR, char *, LONG) );
X\ %? LONG Write ARGs( (BPTR, char *, LONG) );
X\ %? BPTR Input ARGs( (VOID) );
X\ %? BPTR Output ARGs( (VOID) );
X\ %? LONG Seek ARGs( (BPTR, LONG, LONG) );
X\ %? LONG DeleteFile ARGs( (char *) );
X\ %? LONG Rename ARGs( (char *, char *) );
X\ %? BPTR Lock ARGs( (char *, LONG) );
X\ %? VOID UnLock ARGs( (BPTR) );
X\ %? BPTR DupLock ARGs( (BPTR) );
X\ %? LONG Examine ARGs( (BPTR, struct FileInfoBlock *) );
X\ %? LONG ExNext ARGs( (BPTR, struct FileInfoBlock *) );
X\ %? LONG Info ARGs( (BPTR, struct InfoData *) );
X\ %? BPTR CreateDir ARGs( (char *) );
X\ %? BPTR CurrentDir ARGs( (BPTR) );
X\ %? struct MsgPort *CreateProc ARGs( (char *, LONG, BPTR, LONG) );
X\ %? VOID Exit ARGs( (LONG) );
X\ %? BPTR LoadSeg ARGs( (char *) );
X\ %? VOID UnLoadSeg ARGs( (BPTR) );
X\ %? struct MsgPort *DeviceProc ARGs( (char *) );
X\ %? LONG SetComment ARGs( (char *, char *) );
X\ %? LONG SetProtection ARGs( (char *, LONG) );
X\ %? LONG *DateStamp ARGs( (LONG *) );
X\ %? VOID Delay ARGs( (LONG) );
X\ %? LONG WaitForChar ARGs( (BPTR, LONG) );
X\ %? BPTR ParentDir ARGs( (BPTR) );
X\ %? LONG IsInteractive ARGs( (BPTR) );
X\ %? LONG Execute ARGs( (char *, BPTR, BPTR) );
X\ %? #endif DO_ARP_COPIES
X
X\ %? /*
X
X\ %? * Now for the stuff that only exists in arp.library... *
X
X\ %? */
X\ %? LONG C_Args Printf ARGs( (char *,) );
X\ %? LONG C_Args FPrintf ARGs( (BPTR, char *,) );
X\ %? LONG Puts ARGs( (char *) );
X\ %? LONG Readline ARGs( (char *) );
X\ %? LONG GADS ARGs( (char *, LONG, char *, char **, char *) );
X\ %? LONG Atol ARGs( (char *) );
X\ %? ULONG EscapeString ARGs( (char *) );
X\ %? LONG CheckAbort ARGs( (VOID(*)) );
X\ %? LONG CheckBreak ARGs( (LONG, VOID(*)) );
X\ %? BYTE *Getenv ARGs( (char *, char *, LONG) );
X\ %? BOOL Setenv ARGs( (char *, char *) );
X\ %? BYTE *FileRequest ARGs( (struct FileRequester *) );
X\ %? VOID CloseWindowSafely ARGs( (struct Window *, LONG) );
X\ %? struct MsgPort *CreatePort ARGs( (char *, LONG) );
X\ %? VOID DeletePort ARGs( (struct MsgPort *) );
X\ %? LONG SendPacket ARGs( (LONG, LONG *, struct MsgPort *) );
X\ %? VOID InitStdPacket ARGs( (LONG, LONG *, struct DosPacket *, struct MsgPort *) );
X\ %? ULONG PathName ARGs( (BPTR, char *,LONG) );
X\ %? ULONG Assign ARGs( (char *, char *) );
X\ %? VOID *DosAllocMem ARGs( (LONG) );
X\ %? VOID DosFreeMem ARGs( (VOID *) );
X\ %? ULONG BtoCStr ARGs( (char *, BSTR, LONG) );
X\ %? ULONG CtoBStr ARGs( (char *, BSTR, LONG) );
X\ %? struct DeviceList *GetDevInfo ARGs( (struct DeviceList *) );
X\ %? BOOL FreeTaskResList ARGs( (VOID) );
X\ %? VOID ArpExit ARGs( (LONG,LONG) );
X\ %? VOID C_Args *ArpAlloc ARGs( (LONG) );
X\ %? VOID C_Args *ArpAllocMem ARGs( (LONG, LONG) );
X\ %? BPTR C_Args ArpOpen ARGs( (char *, LONG) );
X\ %? BPTR C_Args ArpDupLock ARGs( (BPTR) );
X\ %? BPTR C_Args ArpLock ARGs( (char *, LONG) );
X\ %? VOID C_Args *RListAlloc ARGs( (struct ResList *, LONG) );
X\ %? struct Process *FindCLI ARGs( (LONG) );
X\ %? BOOL QSort ARGs( (VOID *, LONG, LONG, int(*)) );
X\ %? BOOL PatternMatch ARGs( (char *,char *) );
X\ %? LONG FindFirst ARGs( (char *, struct AnchorPath *) );
X\ %? LONG FindNext ARGs( (struct AnchorPath *) );
X\ %? VOID FreeAnchorChain ARGs( (struct AnchorPath *) );
X\ %? ULONG CompareLock ARGs( (BPTR, BPTR) );
X\ %? struct ResList *FindTaskResList ARGs( (VOID) );
X\ %? struct ResList *CreateTaskResList ARGs( (VOID) );
X\ %? VOID FreeResList ARGs( (struct ResList *) );
X\ %? VOID FreeTrackedItem ARGs( (struct DefaultTracker *) );
X\ %? struct DefaultTracker C_Args *GetTracker ARGs( (LONG) );
X\ %? VOID *GetAccess ARGs( (struct DefaultTracker *) );
X\ %? VOID FreeAccess ARGs( (struct DefaultTracker *) );
X\ %? VOID FreeDAList ARGs( (struct DirectoryEntry *) );
X\ %? struct DirectoryEntry *AddDANode ARGs( (char *, struct DirectoryEntry **, LONG, LONG) );
X\ %? ULONG AddDADevs ARGs( (struct DirectoryEntry **, LONG) );
X\ %? LONG Strcmp ARGs( (char *, char *) );
X\ %? LONG Strncmp ARGs( (char *, char *, LONG) );
X\ %? BYTE Toupper ARGs( (BYTE) );
X\ %? LONG SyncRun ARGs( (char *, char *, BPTR, BPTR) );
X
X\ %? /*
X
X\ %? * Added V32 of arp.library *
X
X\ %? */
X\ %? LONG ASyncRun ARGs( (char *, char *, struct ProcessControlBlock *) );
X\ %? LONG SpawnShell ARGs( (char *, char *, struct NewShell *) );
X\ %? BPTR LoadPrg ARGs( (char *) );
X\ %? BOOL PreParse ARGs( (char *, char *) );
X
X\ %? /*
X
X\ %? * Added V33 of arp.library *
X
X\ %? */
X\ %? BOOL StamptoStr ARGs( (struct DateTime *) );
X\ %? BOOL StrtoStamp ARGs( (struct DateTime *) );
X\ %? struct ResidentProgramNode *ObtainResidentPrg ARGs( (char *) );
X\ %? struct ResidentProgramNode *AddResidentPrg ARGs( (BPTR, char *) );
X\ %? LONG RemResidentPrg ARGs( (char *) );
X\ %? VOID UnLoadPrg ARGs( (BPTR) );
X\ %? LONG LMult ARGs( (LONG, LONG) );
X\ %? LONG LDiv ARGs( (LONG, LONG) );
X\ %? LONG LMod ARGs( (LONG, LONG) );
X\ %? ULONG CheckSumPrg ARGs( (struct ResidentProgramNode *) );
X\ %? VOID TackOn ARGs( (char *, char *) );
X\ %? BYTE *BaseName ARGs( (char *) );
X\ %? struct ResidentProgramNode *ReleaseResidentPrg ARGs( (BPTR) );
X
X\ %? /*
X
X\ %? * Added V36 of arp.library *
X
X\ %? */
X\ %? LONG C_Args SPrintf ARGs( (char *, char *,) );
X\ %? LONG GetKeywordIndex ARGs( (char *, char *) );
X\ %? struct Library C_Args *ArpOpenLibrary ARGs( (char *, LONG) );
X\ %? struct FileRequester C_Args *ArpAllocFreq ARGs( (VOID) );
X
X\ %? /*
X
X\ %? * Check if we should do the pragmas... *
X
X\ %? */
X\ %? #ifndef NO_PRAGMAS
X
X\ %? #ifndef PROTO_ARP_H
X\ %? #include <Proto/ARP.h>
X\ %? #endif PROTO_ARP_H
X
X\ %? #endif NO_PRAGMAS
X
X\ %? #endif LIBRARIES_ARPBASE_H
END_OF_FILE
if test 20065 -ne `wc -c <'arp/ArpBase.j.ab'`; then
echo shar: \"'arp/ArpBase.j.ab'\" unpacked with wrong size!
fi
# end of 'arp/ArpBase.j.ab'
fi
if test -f 'arp/arp_support' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'arp/arp_support'\"
else
echo shar: Extracting \"'arp/arp_support'\" \(873 characters\)
sed "s/^X//" >'arp/arp_support' <<'END_OF_FILE'
X\ arp_support
X\ general support for the arp.library
X\ 3/25/90
X\
X\ (c) Copyright 1989. 1990 by Richard Mazzarisi
X\ (rich@californium.cchem.berkeley.edu)
X\
X\ 11/24/89 original library functions and file requester
X\ 3/25/89 alternate open library function
X
XANEW task-arp_support
X
X\ add arp.library to the system
X
X:LIBRARY arp
X
X: arp? arp_name arp_lib LIB? ;
X: -arp arp_lib -LIB ;
X
X
X: open.arp-lib ( -- t/f )
X\ tries to open lib; returns success flag
X\ does NOT automatically quit as does ?arp
X arp_lib DUP @ 0= IF
X arp_name OPENLIB DUP ROT !
X ELSE
X DROP TRUE \ already open
X THEN
X;
X
X
X\ *** functions ***
X
X\ file requester
X
X: ArpAllocFreq() ( -- filerequester )
X\ return a structure relative address for use in FileRequest()
X CALL arp_lib ArpAllocFreq IF>REL
X;
X
X
X: FileRequest() ( filerequester -- filebuffer )
X CALL>ABS arp_lib FileRequest IF>REL
X;
END_OF_FILE
if test 873 -ne `wc -c <'arp/arp_support'`; then
echo shar: \"'arp/arp_support'\" unpacked with wrong size!
fi
# end of 'arp/arp_support'
fi
if test ! -d 'source' ; then
echo shar: Creating directory \"'source'\"
mkdir 'source'
fi
if test -f 'source/FloatIcon.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'source/FloatIcon.f'\"
else
echo shar: Extracting \"'source/FloatIcon.f'\" \(10531 characters\)
sed "s/^X//" >'source/FloatIcon.f' <<'END_OF_FILE'
X\ FloatIcon.f 1.03
X\ Program to release several icons simultaneously so that WorkBench will
X\ handle their placement in a drawer window.
X\ Written in JForth Professional 2.0
X\
X\ (c) Copyright 1989, 1990 by Richard Mazzarisi.
X\ All rights reserved.
X\
X\ address:
X\ 891 Post St. #207
X\ San Francisco, CA
X\ 94109
X\
X\ email:
X\ rich@californium.cchem.berkeley.edu
X\ rmazz@hydrogen.cchem.berkeley.edu
X\
X\
X\ 5/20/90
X\
X\ v. 1.00 10/9/89
X\ v. 1.01 2/3/90 fixed the path name for drawers, WB gives you the name
X\ with a '/' at the end which must be removed whereas
X\ Jazzbench does not
X\ v. 1.02 3/22/90 fixed bug in 'remove.final.slash' was 2DROP changed to DROP
X\ 3/23/90 fixed problem similar to '/' with ':' on device icons
X\ v. 1.03 5/20/90 fixed the ability to find the font size and use this info
X\ in opening the window
X
X\ Instructions:
X\ 1 - Click on the icon for this program.
X\ 2 - Shift click on all icons to be floated.
X\
X\ (NOTE: The author assumes no responsibility for any damages
X\ resulting from the use of this program.)
X
X
XINCLUDE? CLONE CL:TOPFILE
XINCLUDE? LIBRARIES_DOS_H JI:LIBRARIES/DOS.J
XINCLUDE? LIBRARIES_DOSEXTENS_H JI:LIBRARIES/DOSEXTENS.J
XINCLUDE? EXEC_MEMORY_H JI:EXEC/MEMORY.J
XINCLUDE? TASK-AMIGA_GRAPH JU:AMIGA_GRAPH
XINCLUDE? TASK-AMIGA_EVENTS JU:AMIGA_EVENTS
XINCLUDE? TASK-CONSOLESUPPORT JU:CONSOLESUPPORT
XINCLUDE? TASK-ANSISUPPORT JU:ANSISUPPORT
XINCLUDE? TASK-DOS-SUPPORT JU:DOS-SUPPORT
XINCLUDE? TASK-SET-ICON JU:SET-ICON
XINCLUDE? TASK-LOCALS JU:LOCALS
X
X
X.NEED clone-it
X
X\ *** clone controller ***
X
XVARIABLE clone-it
Xclone-it OFF
X
X.THEN
X
X
XANEW task-floaticon
X
XDECIMAL
X
X
X\ *** console stuff ***
X
X\ variables to hold the request and reply ports
XVARIABLE wreq
XVARIABLE rreq
XVARIABLE wreply
XVARIABLE rreply
X
X
X: con.cr ( -- )
X wreq @ $ 0A ConPutChar()
X;
X
X
X: con.write ( straddr -- )
X wreq @ SWAP COUNT ConWrite()
X;
X
X
X: con.write.c3 ( straddr -- )
X\ write string in color 3
X 1 33 2 CRender3 wreq @ >ANSIDEVICE
X con.write
X 0 1 CRender3 wreq @ >ANSIDEVICE
X;
X
X
X: con.write.itl ( straddr -- )
X\ write string in bold italics
X 3 1 2 CRender3 wreq @ >ANSIDEVICE
X con.write
X 0 1 CRender3 wreq @ >ANSIDEVICE
X;
X
X
X: clear.line ( -- )
X\ clear current line
X 0 CDeleteLine wreq @ >ANSIDEVICE
X;
X
X
X: cursor.off ( -- )
X\ get rid of cursor
X 0 CCursOff wreq @ >ANSIDEVICE
X;
X
X
X\ *** main window stuff ***
X
XCREATE scr-buff Sizeof() Screen ALLOT
XNewWindow ft-window
X
X: getWBscreendata ( -- )
X scr-buff Sizeof() Screen WBENCHSCREEN NULL
X CALL>ABS INTUITION_LIB GetScreenData NULL = IF
X ABORT" Could not get Workbench screen data."
X THEN
X;
X
X
X: set.vert-params ( topedge #lines -- topedge' height )
X\ calc window height, adjust topedge if necessary
X scr-buff ..@ sc_Font \ get font
X >REL ..@ ta_YSize \ font height
X \ estimate height from #lines, title bar height and lower border
X * scr-buff ..@ sc_BarHeight + 12 +
X \ check if too high
X 2DUP + scr-buff ..@ sc_Height > IF
X \ try adjusting topedge
X SWAP DROP \ lose old topedge
X scr-buff ..@ sc_Height OVER - DUP 0< IF
X \ not going to work; set to 0 & screen height
X 2DROP
X 0 scr-buff ..@ sc_Height
X ELSE
X SWAP
X THEN
X THEN
X;
X
X
X: set.horiz-params ( leftedge #chars -- leftedge' width )
X\ calc window width, adjust leftedge if necessary
X scr-buff .. sc_RastPort ..@ rp_TxWidth \ get font width
X \ estimate width from #chars, and borders
X * 24 +
X \ check if too wide
X 2DUP + scr-buff ..@ sc_Width > IF
X \ try adjusting leftedge
X SWAP DROP \ lose old leftedge
X scr-buff ..@ sc_Width OVER - DUP 0< IF
X \ not going to work; set to 0 & screen width
X 2DROP
X 0 scr-buff ..@ sc_Width
X ELSE
X SWAP
X THEN
X THEN
X;
X
X
X: open.ft-window ( -- window/null )
X getWBscreendata
X ft-window NEWWINDOW.SETUP
X 20 15 set.vert-params
X ft-window ..! nw_Height
X ft-window ..! nw_TopEdge
X 20 51 set.horiz-params
X ft-window ..! nw_Width
X ft-window ..! nw_LeftEdge
X 0" FloatIcon 1.03" >ABS ft-window ..! nw_Title
X CLOSEWINDOW ft-window ..! nw_IDCMPFlags
X WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING |
X ft-window ..! nw_Flags
X ft-window GR.OPENCURW
X;
X
X
X: wait.close ( -- )
X BEGIN
X GR-CURWINDOW @ EV.WAIT
X GR-CURWINDOW @ EV.GETCLASS
X CLOSEWINDOW =
X UNTIL
X;
X
X
X\ *** string stuff ***
X
X: init.name ( -- )
X 0 PAD !
X;
X
X
X: build.name ( addr count -- )
X\ must init to null with init.name before using this word for the first
X\ time in building a new path name
X PAD @ 0= IF
X PAD >$
X ELSE
X PAD $APPEND
X THEN
X;
X
X
X\ *** resource management ***
X
X: close.ft-things ( -- )
X wait.close
X wreq @ 0= NOT IF
X wreply @ wreq @ rreply @ rreq @ ReleaseConsole()
X wreq OFF
X THEN
X GR.CLOSECURW
X GR.TERM
X;
X
X
X: prt.close-msg ( -- )
X con.cr
X " Click CloseBox to exit." con.write
X;
X
X
X: ft.abort ( -- )
X con.cr prt.close-msg
X close.ft-things
X ABORT
X;
X
X
X: open.ft-things ( -- t/f )
X\ The error messages are for debugging under the interpreter; they won't
X\ be able to be seen under the workbench.
X GR.INIT
X wreq OFF
X GR-CURWINDOW OFF
X \ open window
X open.ft-window NULL = IF
X ABORT" Could not open a window!"
X THEN
X \ make it a console
X gr-curwindow @ GetConsole() NULL = IF
X close.ft-things
X ABORT" Could not create a console device!"
X ELSE
X rreq ! rreply ! wreq ! wreply !
X cursor.off
X THEN
X;
X
X
X\ *** modified words from JU:SET-ICON ***
X\ these must not call ?ABORT" but must use ft.abort to clean up
X\ probably don't need most of the error messages but leave them for debugging
X
X: ft.icon-open? ( -- , just checks for 0 )
X theIcon @ 0= IF
X " ERROR: No Icon selected ... use GET-ICON" con.write.itl con.cr
X ft.abort
X THEN
X;
X
X
X: ft.abort-icon ( -- , just clear it out )
X ft.icon-open? theIcon @ FreeDiskObject()
X theIcon OFF thestrings @ FREEBLOCK
X;
X
X
X: $ft.get-icon ( adr-forth-string -- )
X \ NOTE: do NOT include the '.info' suffix in the pathname
X theIcon @ IF
X " ERROR: 'theIcon' currently holds another icon."
X con.write.itl con.cr
X ft.abort
X THEN
X COUNT >DOS DOS0 GetDiskObject() -DUP 0= IF
X " ERROR: Can't Get the ICON file!" con.write.itl con.cr
X ft.abort
X THEN
X theIcon ! MEMF_PUBLIC 1024 ALLOCBLOCK -DUP 0= IF
X " ERROR: No memory for ICON strings!" con.write.itl con.cr
X ft.abort
X ELSE
X thestrings !
X THEN
X;
X
X
X: $ft.save-icon ( adr-forth-string -- )
X \ AGAIN...do not append the '.info'
X ft.icon-open? COUNT >DOS DOS0 theIcon @ PutDiskObject() 0= IF
X " ERROR while saving DiskObject!" con.write.itl con.cr
X ft.abort
X THEN
X theIcon @ FreeDiskObject() theIcon OFF thestrings @ FREEBLOCK
X;
X
X
X\ *** support ***
X
X: ft.greeting ( -- )
X " Release icons to be freely placed by Workbench." con.write.itl con.cr
X " (c) Copyright by Richard Mazzarisi 1989, 1990" con.write.c3 con.cr
X " All rights reserved." con.write.c3 con.cr
X " Written in JForth Professional 2.0." con.write.c3 con.cr con.cr
X;
X
X
X: prt.instr ( -- )
X " Instructions:" con.write con.cr
X " 1 - Click on the icon for this program." con.write con.cr
X " 2 - Shift click on all the icons to be floated." con.write con.cr
X con.cr
X " (NOTE: The author assumes no responsibility for any"
X con.write con.cr
X " damages resulting from the use of this program.)" con.write con.cr
X;
X
X
X: check.WB ( -- )
X \ check if running under WorkBench?
X WBMESSAGE @ NOT IF
X " Must be run under the WorkBench!" con.write.itl con.cr con.cr
X prt.instr ft.abort
X THEN
X;
X
X
X: check.num.args ( -- n t | f )
X\ We need at least two args to make any sense.
X\ returns number of arguments and true; or false if not enough
X WBMESSAGE @ >REL ..@ sm_NumArgs DUP 2 < IF
X \ not enough args; tell'em how
X " You must click on at least one other icon!" con.write.itl con.cr con.cr
X prt.instr prt.close-msg
X DROP FALSE
X ELSE
X 1- ( 1st is FloatIcon )
X TRUE
X THEN
X;
X
X
X: alloc.fib ( -- fib-addr )
X \ allocate memory for the File Info Block
X MEMF_CLEAR SizeOf() FileInfoBlock ALLOCBLOCK
X DUP NULL = IF
X " ERROR: Could not allocate FileInfoBlock!" con.write.itl
X THEN
X;
X
X
X: dealloc.fib ( fib-addr -- )
X DUP IF
X FREEBLOCK
X THEN
X;
X
X
X: get.parentdir { lock | fib pdirflg dirflg ok --> dirflg ok }
X\ return in dirflg t if parent is a directory, f if it is disk (root) and t/f
X\ obviously dirflg is useless if all is not OK
X TRUE -> ok TRUE -> dirflg
X alloc.fib DUP -> fib IF
X \ go upward recursively
X lock ParentDir() -DUP IF
X DUP fib Examine() DROP
X RECURSE SWAP -> pdirflg IF
X fib .. fib_FileName 0COUNT build.name
X pdirflg IF
X " /" COUNT build.name
X ELSE
X " :" COUNT build.name
X THEN
X ELSE
X FALSE -> ok
X THEN
X ELSE
X \ stop! reached the root dir, i.e. 'disk:'
X FALSE -> dirflg
X THEN
X fib dealloc.fib
X ELSE
X FALSE -> ok
X THEN
X;
X
X
X: remove.final.slash ( stradd -- )
X\ get rid of final slash or colon on the name if there
X DUP C@
X OVER + C@ ASCII / = IF
X DUP C@ 1- SWAP C!
X ELSE
X DROP
X THEN
X;
X
X
X: ?dev_name ( stradd -- )
X\ return true if name ends in a colon
X DUP C@
X SWAP + C@ ASCII : =
X;
X
X
X: get.full-path { wbarg | fib pdirflg ok --> ok }
X\ full path of file is written into PAD
X init.name
X TRUE -> ok
X alloc.fib DUP -> fib IF
X \ get the directory path
X wbarg ..@ wa_Lock fib Examine() DROP
X wbarg ..@ wa_Lock get.parentdir SWAP -> pdirflg IF
X \ get directory name
X fib .. fib_FileName 0COUNT build.name
X pdirflg IF
X " /" COUNT build.name
X ELSE
X " :" COUNT build.name
X THEN
X \ get name
X wbarg ..@ wa_Name >REL 0COUNT build.name
X ELSE
X FALSE -> ok
X THEN
X fib dealloc.fib
X PAD remove.final.slash
X PAD ?dev_name IF
X \ possibly a disk; try...
X " Disk" COUNT build.name
X THEN
X ELSE
X FALSE -> ok
X THEN
X;
X
X
X: float.it ( -- )
X PAD $ft.get-icon
X[ clone-it @ ] .IF
X SET-NO-POSITION
X PAD $ft.save-icon
X.ELSE
X\ don't really do it if we are testing things in the interpreter
X ft.abort-icon
X.THEN
X;
X
X
X: float.one { wbarg -- }
X \ get file's path name
X wbarg get.full-path IF
X " " con.write
X PAD con.write con.cr
X float.it
X ELSE
X " ERROR: Could not get path for project:" con.write.itl con.cr
X " " con.write
X wreq @ wbarg ..@ wa_Name >REL ConPutStr() con.cr
X THEN
X;
X
X
X: do.floats { #args -- }
X \ get pointer to args
X WBMESSAGE @ >REL ..@ sm_ArgList >REL
X \ 2rd and on are the icons to be floated
X #args 1+ 1 DO
X DUP SizeOf() WBArg I * +
X float.one
X \ check for stop action
X ?CLOSEBOX IF LEAVE THEN
X LOOP
X DROP
X con.cr " Done. " con.write.itl
X;
X
X
X\ *** main ***
X
X: floaticon ( -- )
X open.ft-things
X cursor.off
X ft.greeting
X check.WB
X check.num.args IF
X do.floats
X " Click CloseBox to exit." con.write
X THEN
X close.ft-things
X;
X
X
X: ft
X floaticon
X;
X
X
Xclone-it @ .IF
X
Xinitclone
Xclone ft
Xsave-image FloatIcon FloatIcon -icon
X
X.THEN
X
XCR CR ." Type 'ft' to run." CR CR
END_OF_FILE
if test 10531 -ne `wc -c <'source/FloatIcon.f'`; then
echo shar: \"'source/FloatIcon.f'\" unpacked with wrong size!
fi
# end of 'source/FloatIcon.f'
fi
if test -f 'source/ReplaceTool.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'source/ReplaceTool.f'\"
else
echo shar: Extracting \"'source/ReplaceTool.f'\" \(16259 characters\)
sed "s/^X//" >'source/ReplaceTool.f' <<'END_OF_FILE'
X\ ReplaceTool.f 2.02
X\ Program to change the default tool of a number project icons simultaneously,
X\ using the Workbench and Intuition.
X\ Written in JForth Professional 2.0
X\
X\ (c) Copyright 1989, 1990 by Richard Mazzarisi
X\ All rights reserved.
X\
X\ address:
X\ 891 Post St. #207
X\ San Francisco, CA
X\ 94109
X\
X\ email:
X\ rich@californium.cchem.berkeley.edu
X\ rmazz@hydrogen.cchem.berkeley.edu
X\ nmr@garnet.berkeley.edu
X\
X\
X\ 5/20/90
X\
X\ v. 1.00 9/2/89
X\ v. 1.01 10/9/89 order of clicking icons no longer matters
X\ v. 2.00 2/1/90 added arp file requester if no tool clicked
X\ v. 2.01 3/22/90 fixed problem with final slash in drawer names from WB; if
X\ a drawer was selected prog does error exit
X\ (not a problem with JazzBench)
X\ 3/24/90 fixed problem similar to '/' with ':' on device icons
X\ 3/25/90 moved arp library openning away from startup - it is not
X\ needed unless no tool icon is selected; no need to
X\ abort if user clicks on a tool along with projects
X\ v. 2.02 5/15/90 fixed the tendency to crash if the arp file req returns
X\ a null string for the drawer
X\ 5/20/90 fixed the ability to find the font size and use this info
X\ in opening the window
X\
X\ Instructions:
X\ 1 - Click on the icon for this program.
X\ 2 - Shift click on the Project icons to have their
X\ DefaultTool changed and the icon for the Tool to be
X\ set as the DefaultTool.
X\ 3 - OR shift click only on Project icons; a file requester will
X\ appear allowing the DefaultTool to be selected.
X\
X\ (NOTE: The author assumes no responsibility for any damages
X\ resulting from the use of this program.)
X
XINCLUDE? CLONE CL:TOPFILE
XINCLUDE? LIBRARIES_DOS_H JI:LIBRARIES/DOS.J
XINCLUDE? LIBRARIES_DOSEXTENS_H JI:LIBRARIES/DOSEXTENS.J
XINCLUDE? EXEC_MEMORY_H JI:EXEC/MEMORY.J
XINCLUDE? TASK-AMIGA_GRAPH JU:AMIGA_GRAPH
XINCLUDE? TASK-AMIGA_EVENTS JU:AMIGA_EVENTS
XINCLUDE? TASK-CONSOLESUPPORT JU:CONSOLESUPPORT
XINCLUDE? TASK-ANSISUPPORT JU:ANSISUPPORT
XINCLUDE? TASK-DOS-SUPPORT JU:DOS-SUPPORT
XINCLUDE? TASK-AUTO_REQUEST JU:AUTO_REQUEST
XINCLUDE? TASK-SET-ICON JU:SET-ICON
XINCLUDE? TASK-LOCALS JU:LOCALS
XINCLUDE? LIBRARIES_ARPBASE_H JARP:ARPBASE.J
XINCLUDE? TASK-ARP_SUPPORT JARP:ARP_SUPPORT
X
X
X.NEED clone-it
X
X\ *** clone controller ***
X
XVARIABLE clone-it
Xclone-it OFF
X
X.THEN
X
X
XANEW task-replacetool
X
XDECIMAL
X
X
X\ *** constants ***
X
X\ # bytes to be allocated for the path string; biggest string which can
X\ be returned from arp filerequester
XLONG_DSIZE LONG_FSIZE + 1+ CONSTANT pathsize
X
X\ *** variables ***
X
XVARIABLE toolarg \ holds the position of the Tool arg
X
X\ *** console stuff ***
X
X\ variables to hold the request and reply ports
XVARIABLE wreq
XVARIABLE rreq
XVARIABLE wreply
XVARIABLE rreply
X
X
X: con.cr ( -- )
X wreq @ $ 0A ConPutChar()
X;
X
X
X: con.write ( straddr -- )
X wreq @ SWAP COUNT ConWrite()
X;
X
X
X: con.write.c3 ( straddr -- )
X\ write string in color 3
X 1 33 2 CRender3 wreq @ >ANSIDEVICE
X con.write
X 0 1 CRender3 wreq @ >ANSIDEVICE
X;
X
X
X: con.write.itl ( straddr -- )
X\ write string in bold italics
X 3 1 2 CRender3 wreq @ >ANSIDEVICE
X con.write
X 0 1 CRender3 wreq @ >ANSIDEVICE
X;
X
X
X: clear.line ( -- )
X\ clear current line
X 0 CDeleteLine wreq @ >ANSIDEVICE
X;
X
X
X: cursor.off ( -- )
X\ get rid of cursor
X 0 CCursOff wreq @ >ANSIDEVICE
X;
X
X
X\ *** main window stuff ***
X
XCREATE scr-buff Sizeof() Screen ALLOT
XNewWindow rt-window
X
X: getWBscreendata ( -- )
X scr-buff Sizeof() Screen WBENCHSCREEN NULL
X CALL>ABS INTUITION_LIB GetScreenData NULL = IF
X ABORT" Could not get Workbench screen data."
X THEN
X;
X
X
X: set.vert-params ( topedge #lines -- topedge' height )
X\ calc window height, adjust topedge if necessary
X scr-buff ..@ sc_Font \ get font
X >REL ..@ ta_YSize \ font height
X \ estimate height from #lines, title bar height and lower border
X * scr-buff ..@ sc_BarHeight + 12 +
X \ check if too high
X 2DUP + scr-buff ..@ sc_Height > IF
X \ try adjusting topedge
X SWAP DROP \ lose old topedge
X scr-buff ..@ sc_Height OVER - DUP 0< IF
X \ not going to work; set to 0 & screen height
X 2DROP
X 0 scr-buff ..@ sc_Height
X ELSE
X SWAP
X THEN
X THEN
X;
X
X
X: set.horiz-params ( leftedge #chars -- leftedge' width )
X\ calc window width, adjust leftedge if necessary
X scr-buff .. sc_RastPort ..@ rp_TxWidth \ get font width
X \ estimate width from #chars, and borders
X * 24 +
X \ check if too wide
X 2DUP + scr-buff ..@ sc_Width > IF
X \ try adjusting leftedge
X SWAP DROP \ lose old leftedge
X scr-buff ..@ sc_Width OVER - DUP 0< IF
X \ not going to work; set to 0 & screen width
X 2DROP
X 0 scr-buff ..@ sc_Width
X ELSE
X SWAP
X THEN
X THEN
X;
X
X
X: open.rt-window ( -- window/null )
X getWBscreendata
X rt-window NEWWINDOW.SETUP
X 20 20 set.vert-params
X rt-window ..! nw_Height
X rt-window ..! nw_TopEdge
X 20 55 set.horiz-params
X rt-window ..! nw_Width
X rt-window ..! nw_LeftEdge
X 0" ReplaceTool 2.02" >ABS rt-window ..! nw_Title
X CLOSEWINDOW rt-window ..! nw_IDCMPFlags
X WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING |
X rt-window ..! nw_Flags
X rt-window GR.OPENCURW
X;
X
X
X: wait.close ( -- )
X BEGIN
X GR-CURWINDOW @ EV.WAIT
X GR-CURWINDOW @ EV.GETCLASS
X CLOSEWINDOW =
X UNTIL
X;
X
X
X\ *** string stuff ***
X
XCREATE pathstr pathsize ALLOT \ holds path to be put into Icons
X
X: init.name ( dest -- )
X 0 SWAP !
X;
X
X
X: build.name ( addr count dest -- )
X\ build string in buffer at dest, must init to null with init.name before
X\ using this word for the first time in building a new path name
X \ check for a non null in first place
X DUP @ 0= IF
X \ it was just initialized so just copy
X >$
X ELSE
X $APPEND
X THEN
X;
X
X
X\ *** resource management ***
X
X: close.rt-things ( -- )
X con.cr " Click CloseBox to exit." con.write
X wait.close
X wreq @ 0= NOT IF
X wreply @ wreq @ rreply @ rreq @ ReleaseConsole()
X wreq OFF
X THEN
X GR.CLOSECURW
X GR.TERM \ close graphics
X -ARP \ and arp.library if it was used
X;
X
X
X: rt.abort ( -- )
X con.cr
X close.rt-things
X ABORT
X;
X
X
X: open.rt-things ( -- t/f )
X\ The error messages are for debugging under the interpreter; they won't
X\ be able to be seen under the workbench.
X GR.INIT \ open graphics
X wreq OFF
X GR-CURWINDOW OFF
X \ open window
X open.rt-window NULL = IF
X -ARP
X ABORT" Could not open a window!"
X THEN
X \ make it a console
X GR-CURWINDOW @ GetConsole() NULL = IF
X close.rt-things
X ABORT" Could not create a console device!"
X ELSE
X rreq ! rreply ! wreq ! wreply !
X cursor.off
X THEN
X;
X
X
X\ *** modified words from JU:SET-ICON ***
X\ these must not call ?ABORT" but must use rt.abort to clean up
X\ (probably don't need most of the error messages but leave them for
X\ debugging from the interpreter)
X
X: rt.icon-open? ( -- , just checks for 0 )
X theIcon @ 0= IF
X " ERROR: No Icon selected ... use GET-ICON" con.write.itl con.cr
X rt.abort
X THEN
X;
X
X
X: rt.abort-icon ( -- , just clear it out )
X rt.icon-open? theIcon @ FreeDiskObject()
X theIcon OFF thestrings @ FREEBLOCK
X;
X
X
X: $rt.get-icon ( adr-forth-string -- )
X\ NOTE: do NOT include the '.info' suffix in the pathname
X\ does not work for DRAWER icons under WB (see ju:set-icon)
X\ this does however work with JazzBench
X theIcon @ IF
X " ERROR: 'theIcon' currently holds another icon."
X con.write.itl con.cr
X rt.abort
X THEN
X COUNT >DOS DOS0 GetDiskObject() -DUP 0= IF
X " ERROR: Can't Get the ICON file!" con.write.itl con.cr
X rt.abort
X THEN
X theIcon ! MEMF_PUBLIC 1024 ALLOCBLOCK -DUP 0= IF
X " ERROR: No memory for ICON strings!" con.write.itl con.cr
X rt.abort
X ELSE
X thestrings !
X THEN
X;
X
X
X: $rt.save-icon ( adr-forth-string -- )
X \ AGAIN...do not append the '.info'
X rt.icon-open? COUNT >DOS DOS0 theIcon @ PutDiskObject() 0= IF
X " ERROR while saving DiskObject!" con.write.itl con.cr
X rt.abort
X THEN
X theIcon @ FreeDiskObject() theIcon OFF thestrings @ FREEBLOCK
X;
X
X
X\ *** modified words from JU:AUTO_REQUEST ***
X\ want to change the dimensions and position of the requester
X
X: 0rt.auto.request ( 0body 0posi 0nega -- flag )
X AR.INIT
X ACTIVE-WINDOW
X BODYTEXT
X POSITEXT
X NEGATEXT
X 0 0 320 60 ( these are changed )
X CALL>ABS INTUITION_LIB AutoRequest
X;
X
X
X: $rt.auto.request ( $body $posi $nega -- flag )
X AR-NEGA-CHARS AR.GET.TEXT
X AR-POSI-CHARS AR.GET.TEXT
X AR-BODY-CHARS AR.GET.TEXT
X AR-BODY-CHARS AR-POSI-CHARS AR-NEGA-CHARS
X 0rt.auto.request
X;
X
X
X
X\ *** support ***
X
X: rt.greeting ( -- )
X " Replace the DefaultTool of Project Icons." con.write.itl con.cr
X " (c) Copyright by Richard Mazzarisi 1989, 1990" con.write.c3 con.cr
X " All rights reserved." con.write.c3 con.cr
X " Written in JForth Professional 2.0." con.write.c3 con.cr con.cr
X;
X
X
X: prt.instr ( -- )
X " Instructions:" con.write con.cr
X " 1 - Click on the icon for this program." con.write con.cr
X " 2 - Shift click on the Project icons to have their" con.write con.cr
X " DefaultTool changed and the icon for the Tool to" con.write con.cr
X " be set as the DefaultTool. Order is not important." con.write con.cr
X " 3 - OR shift click only on Project icons;" con.write con.cr
X " a file requester will appear allowing the" con.write con.cr
X " DefaultTool to be selected." con.write con.cr con.cr
X " (NOTE: The author assumes no responsibility for any"
X con.write con.cr
X " damages resulting from the use of this program.)" con.write con.cr
X;
X
X
X: check.WB ( -- )
X \ check if running under WorkBench?
X WBMESSAGE @ NOT IF
X " Must be run under the WorkBench!" con.write.itl con.cr con.cr
X prt.instr rt.abort
X THEN
X;
X
X
X: check.num.args ( -- n t | f )
X\ We need at least three args to make any sense.
X\ returns number of project arguments and true; or false if not enough
X WBMESSAGE @ >REL ..@ sm_NumArgs DUP 2 < IF
X \ not enough args; tell'em how
X " Too few arguments!" con.write.itl con.cr con.cr
X prt.instr
X DROP FALSE
X ELSE
X 1- ( 1st arg is ReplaceTool )
X TRUE
X THEN
X;
X
X
X: alloc.fib ( -- fib-addr )
X \ allocate memory for the File Info Block
X MEMF_CLEAR SizeOf() FileInfoBlock ALLOCBLOCK
X DUP NULL = IF
X " ERROR: Could not allocate FileInfoBlock!" con.write.itl
X THEN
X;
X
X
X: dealloc.fib ( fib-addr -- )
X \ deallocate memory for the File Info Block
X DUP IF
X FREEBLOCK
X THEN
X;
X
X
X: get.parentdir { lock | fib pdirflg dirflg ok --> dirflg ok }
X\ return in dirflg t if parent is a directory, f if it is disk (root) and t/f
X\ obviously dirflg is useless if all is not OK
X TRUE -> ok TRUE -> dirflg
X alloc.fib DUP -> fib IF
X \ go upward recursively
X lock ParentDir() -DUP IF
X DUP fib Examine() DROP
X RECURSE SWAP -> pdirflg IF
X fib .. fib_FileName 0COUNT PAD build.name
X pdirflg IF
X " /" COUNT PAD build.name
X ELSE
X " :" COUNT PAD build.name
X THEN
X ELSE
X FALSE -> ok
X THEN
X ELSE
X \ stop! reached the root dir, i.e. 'disk:'
X FALSE -> dirflg
X THEN
X fib dealloc.fib
X ELSE
X FALSE -> ok
X THEN
X;
X
X
X: remove.final.slash ( stradd -- )
X\ get rid of final slash on the name if there (put on drawer names by WB)
X DUP C@
X OVER + C@ ASCII / = IF
X DUP C@ 1- SWAP C!
X ELSE
X DROP
X THEN
X;
X
X
X: ?dev_name ( stradd -- )
X\ return true if name ends in a colon
X DUP C@
X SWAP + C@ ASCII : =
X;
X
X
X: get.full-path { wb-arg | fib pdirflg ok --> ok }
X\ full path of file in wb-arg is written into PAD
X PAD init.name
X TRUE -> ok
X alloc.fib DUP -> fib IF
X \ get the directory path
X wb-arg ..@ wa_Lock fib Examine() DROP
X wb-arg ..@ wa_Lock get.parentdir SWAP -> pdirflg IF
X \ get directory name
X fib .. fib_FileName 0COUNT PAD build.name
X pdirflg IF
X " /" COUNT PAD build.name
X ELSE
X " :" COUNT PAD build.name
X THEN
X \ get name
X wb-arg ..@ wa_Name >REL 0COUNT PAD build.name
X ELSE
X FALSE -> ok
X THEN
X fib dealloc.fib
X PAD remove.final.slash
X PAD ?dev_name IF
X \ possibly a disk; try...
X " Disk" COUNT PAD build.name
X THEN
X ELSE
X FALSE -> ok
X THEN
X;
X
X
X: check.if.tool { wb-arg -- t/f }
X\ check if file in wb-arg is a tool
X\ this will abort if fed a drawer under WB; OK however under JazzBench
X \ get file's path name
X wb-arg get.full-path IF
X PAD $rt.get-icon
X theIcon @ ..@ do_Type WBTOOL =
X rt.abort-icon
X ELSE
X " ERROR: Could not get path for:" con.write.itl
X wreq @ wb-arg ..@ wa_Name >REL ConPutStr()
X rt.abort
X THEN
X;
X
X
X: find.tool ( wb-arg #args -- )
X\ sets toolarg to # of the first(!) Tool found; 0 if none found
X 0 toolarg !
X \ go thru icons to find the Tool
X 1+ 1 DO
X DUP SizeOf() WBArg I * +
X check.if.tool IF
X I toolarg ! LEAVE
X THEN
X LOOP
X DROP
X;
X
X
X: verify.tool-path ( -- t/f )
X\ verify with user that path is OK
X " DefaultTool path will be: " con.write con.cr
X " " con.write
X pathstr con.write con.cr con.cr
X " Is the DefaultTool path OK to use?"
X " OK, do it!" " No, Cancel" $rt.auto.request IF
X " Click closebox to abort." con.write
X con.cr con.cr
X TRUE
X ELSE
X " Cancelled!" con.write.itl con.cr
X FALSE
X THEN
X;
X
X
X: do.requester ( -- frstruct | f )
X\ uses arp.library file requester to get tool path
X\ returns relative pointer to filerequester structure or false
X ArpAllocFreq() DUP IF
X 0" Select Tool to be used:" >ABS OVER ..! fr_Hail
X \ set default dir (make sure CMOVE's count is OK)
X 0" SYS:" OVER ..@ fr_Dir >REL 5 CMOVE
X DUP FileRequest() -DUP 0= IF
X \ return is 0 => Cancel hit
X " Cancelled!" con.write.itl con.cr
X DROP FALSE
X ELSE
X C@ 0= IF
X \ string empty => return key hit with
X \ no file selected
X " ERROR: No tool selected!" con.write.itl
X con.cr con.cr
X prt.instr
X DROP FALSE
X THEN
X THEN
X ELSE
X " ERROR: Could not get file requester!" con.write.itl con.cr
X THEN
X;
X
X
X: setup.pathstr ( frstruct -- )
X\ writes path and tool name from arp file requester into pathstr
X pathstr init.name
X \ build directory name if one given
X DUP ..@ fr_Dir >REL DUP C@ 0> IF
X \ path is not empty
X 0COUNT 2DUP pathstr build.name
X \ make sure this not a device name
X 1- + C@ DUP ASCII : = NOT SWAP ASCII / = NOT AND IF
X \ ok to put in a '/'
X " /" COUNT pathstr build.name
X THEN
X ELSE
X DROP
X THEN
X \ now add file name
X ..@ fr_File >REL 0COUNT pathstr build.name
X;
X
X
X: request.tool-path ( -- t/f )
X\ get Tool via the arp file requester, set up string and check with user
X\ (probably should check if in fact a Tool was selected, but we have no icon)
X open.arp-lib IF
X do.requester -DUP IF
X setup.pathstr
X verify.tool-path
X ELSE
X FALSE
X THEN
X ELSE
X " ERROR: Could not open arp.library!" con.write.itl
X con.cr con.cr
X prt.instr
X FALSE
X THEN
X;
X
X
X: find.tool-path { wb-arg -- t/f }
X\ writes full path of tool into pathstr
X wb-arg toolarg @ SizeOf() WBArg * +
X get.full-path IF
X PAD pathstr $MOVE
X verify.tool-path
X ELSE
X " ERROR: Could not get path for the tool: " con.write.itl
X wreq @ wb-arg toolarg @ SizeOf() WBArg * + ..@ wa_Name >REL
X ConPutStr() con.cr
X FALSE
X THEN
X;
X
X
X: get.tool-path ( wbarg -- t/f )
X toolarg @ IF
X find.tool-path
X ELSE
X \ no tool specified, use requester
X DROP request.tool-path
X THEN
X;
X
X
X: replace.it ( -- )
X\ replaces the DefaultTool only if the icon represents a Project
X PAD $rt.get-icon
X theIcon @ ..@ do_Type WBPROJECT = IF
X[ clone-it @ ] .IF
X pathstr $SET-DEFAULT-TOOL
X PAD $rt.save-icon
X.ELSE
X\ don't really do it if we are testing things in the interpreter
X rt.abort-icon
X.THEN
X ELSE
X " is not a project! Default tool not replaced"
X con.write.itl con.cr con.cr
X rt.abort-icon
X THEN
X;
X
X
X: make.one-rplcmt { wb-arg -- }
X \ get file's path name
X wb-arg get.full-path IF
X " " con.write
X PAD con.write con.cr
X replace.it
X ELSE
X " ERROR: Could not get path for project:" con.write.itl con.cr
X " " con.write
X wreq @ wb-arg ..@ wa_Name >REL ConPutStr() con.cr
X THEN
X;
X
X
X: do.replacements ( wb-arg #args -- )
X \ go thru icons of the projects to be changed
X \ skipping the tool
X " Replacing the DefaultTool for:" con.write con.cr
X 1+ 1 DO
X I toolarg @ = NOT IF
X DUP SizeOf() WBArg I * +
X make.one-rplcmt
X THEN
X \ check for stop action
X ?CLOSEBOX IF LEAVE THEN
X LOOP
X DROP
X con.cr " Done. " con.write.itl
X;
X
X
X\ *** main ***
X
X: replacetool ( -- )
X open.rt-things
X cursor.off
X rt.greeting
X check.WB
X check.num.args IF
X \ get pointer to args
X WBMESSAGE @ >REL ..@ sm_ArgList >REL SWAP
X 2DUP find.tool
X OVER get.tool-path
X IF
X do.replacements
X ELSE
X 2DROP
X THEN
X THEN
X close.rt-things
X;
X
X
X: rt
X replacetool
X;
X
X
Xclone-it @ .IF
X
Xinitclone
Xclone replacetool
Xsave-image replacetool ReplaceTool -icon
X
X.THEN
X
XCR CR ." Type 'rt' to run." CR CR
END_OF_FILE
if test 16259 -ne `wc -c <'source/ReplaceTool.f'`; then
echo shar: \"'source/ReplaceTool.f'\" unpacked with wrong size!
fi
# end of 'source/ReplaceTool.f'
fi
echo shar: End of archive 1 \(of 2\).
cp /dev/null ark1isdone
MISSING=""
for I in 1 2 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked both archives.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Mail submissions (sources or binaries) to <amiga@cs.odu.edu>.
Mail comments to the moderator at <amiga-request@cs.odu.edu>.
Post requests for sources, and general discussion to comp.sys.amiga.