\ Section: History \ \ image2file 1.2a - extract files from Apple disk images \ \ Ronald T. Kneusel, freeware, July 1996. AMDG \ rkneusel@post.its.mcw.edu \ \ Last update: 13-Jul-99 (fix END token bug) \ \ (this code compiles under Yerk 3.6.7) \ \ ****************************************************************************** \ \ Task Status Date \ ---------------------------------------------------------------------- \ auto-ID of disk image type and order Complete 30-Jul-96 \ allow wild cards in DOS 3.3 copies Complete 06-Aug-96 \ command line interface Complete 06-Aug-96 \ ProDOS file copy Complete 08-Aug-96 \ ProDOS file copy w/wildcards Complete 08-Aug-96 \ ¥standalone application [version 1.0] Complete 12-Aug-96 \ Pascal catalog Complete 15-Aug-96 \ Pascal file copy Complete 15-Aug-96 \ Pascal file copy [w/wildcards] Complete 15-Aug-96 \ ¥standalone application [version 1.1] Complete 15-Aug-96 \ display type and order selected on image load Complete 20-Aug-96 \ new command to override autoselect's choices Complete 20-Aug-96 \ ¥standalone application [version 1.2] Complete 20-Aug-96 \ Integer Basic de-tokenizing [DOS only] Incomplete \ \ ****************************************************************************** \ Section: Declarations \ ========================================================== \ Constants \ ========================================================== 143360 constant IMAGE_SIZE ( images are 140k bytes long ) 1 constant TRUE 0 constant FALSE 0 constant DOS33 ( image orders and types ) 1 constant PRODOS 2 constant PASCAL $ 54455854 constant ( Mac file type codes ) $ 42494E20 constant $ 414C4641 constant $ 3F3F3F3F constant \ ========================================================== \ Objects \ ========================================================== File disk \ disk image file File output \ output file 0 Value buff \ address of image file buffer 0 Value outbuff \ address of output file buffer 0 Value tempbuff \ address of temporary buffer 0 Value buffIndex \ offset into output buffer 0 Value tempIndex \ offset into temp buffer 0 Value image_order \ 0=DOS 3.3, 1=ProDOS 0 Value image_type \ 0=DOS 3.3, 1=ProDOS, 2=Pascal 0 Value image? \ TRUE=image loaded String outname \ name of output file String command \ command line input String s \ general use String t String w String p String g sArray tokens \ list of BASIC keywords sArray fnames \ list of filenames in image 8 Array p_low \ sectors holding low part of ProDOS block 8 Array p_high \ " " high " " " " 16 Array d_map \ relative block containing the sector 16 Array d_half \ offset for sector within rel. block \ Section: Utility Words \ ========================================================== \ Utility words \ ========================================================== \ ------------------------------------ \ Initialize memory \ ------------------------------------ : initMemory ( -- t|f ) \ grab memory for a disk image IMAGE_SIZE newPtr \ and output buffer dup 0 > if \ and a tempory buffer -> buff IMAGE_SIZE newPtr dup 0 > if -> outbuff IMAGE_SIZE newPtr dup 0 > if -> tempbuff TRUE else drop FALSE then else drop FALSE then else drop FALSE then ; \ ------------------------------------ \ Display a system error \ ------------------------------------ : .error ( ec -- ) . ." error" cr ; \ ------------------------------------ \ print a number with leading zero \ ------------------------------------ : .p { n -- } n 9 > if n 2 .r else ascii 0 emit n 48 + emit then ; \ ------------------------------------------ \ Automatically set the image order and type \ ------------------------------------------ : autodetect { \ ord typ s1 -- } DOS33 -> ord DOS33 -> typ \ default buff c@ buff 1+ c@ buff 2+ c@ buff 3+ c@ + + + -> s1 s1 406 = if DOS33 -> typ then s1 236 = if PRODOS -> typ then s1 513 = if PASCAL -> typ then getName: disk put: s start: s uc: s drop drop start: s " .DSK" indexOf: s if drop DOS33 -> ord then start: s " .PO" indexOf: s if drop PRODOS -> ord then typ -> image_type ord -> image_order cr ." Image type: " typ CASE DOS33 OF ." DOS 3.3" ENDOF PRODOS OF ." ProDOS" ENDOF PASCAL OF ." Pascal" ENDOF ENDCASE cr ." order: " ord DOS33 = IF ." DOS 3.3" ELSE ." ProDOS" THEN cr cr ; \ ------------------------------------ \ Read an image file from disk \ ------------------------------------ : readFile ( -- t|f ) 0 stdget: disk if openReadOnly: disk 0= if size: disk IMAGE_SIZE = if buff IMAGE_SIZE read: disk dup 0= if drop TRUE \ read without error else .error FALSE then else ." File is not an image file." cr FALSE then close: disk drop autodetect \ set image type and order then else FALSE then ; \ ------------------------------------ \ Build an array of BASIC tokens \ ------------------------------------ : loadTokens ( -- ) new: tokens ( reserve space ) " END " add: tokens " FOR " add: tokens " NEXT " add: tokens " DATA " add: tokens " INPUT " add: tokens " DEL " add: tokens " DIM " add: tokens " READ " add: tokens " GR " add: tokens " TEXT " add: tokens " PR# " add: tokens " IN# " add: tokens " CALL " add: tokens " PLOT " add: tokens " HLIN " add: tokens " VLIN " add: tokens " HGR2 " add: tokens " HGR " add: tokens " HCOLOR= " add: tokens " HPLOT " add: tokens " DRAW " add: tokens " XDRAW " add: tokens " HTAB " add: tokens " HOME " add: tokens " ROT= " add: tokens " SCALE= " add: tokens " SHLOAD " add: tokens " TRACE " add: tokens " NOTRACE " add: tokens " NORMAL " add: tokens " INVERSE " add: tokens " FLASH " add: tokens " COLOR= " add: tokens " POP " add: tokens " VTAB " add: tokens " HIMEM: " add: tokens " LOMEM: " add: tokens " ONERR " add: tokens " RESUME " add: tokens " RECALL " add: tokens " STORE " add: tokens " SPEED= " add: tokens " LET " add: tokens " GOTO " add: tokens " RUN " add: tokens " IF " add: tokens " RESTORE " add: tokens " & " add: tokens " GOSUB " add: tokens " RETURN " add: tokens " REM " add: tokens " STOP " add: tokens " ON " add: tokens " WAIT " add: tokens " LOAD " add: tokens " SAVE " add: tokens " DEF " add: tokens " POKE " add: tokens " PRINT " add: tokens " CONT " add: tokens " LIST " add: tokens " CLEAR " add: tokens " GET " add: tokens " NEW " add: tokens " TAB( " add: tokens " TO " add: tokens " FN " add: tokens " SPC( " add: tokens " THEN " add: tokens " AT " add: tokens " NOT " add: tokens " STEP " add: tokens " +" add: tokens " -" add: tokens " *" add: tokens " /" add: tokens " ^" add: tokens " AND " add: tokens " OR " add: tokens " >" add: tokens " =" add: tokens " <" add: tokens " SGN" add: tokens " INT" add: tokens " ABS" add: tokens " USR" add: tokens " FRE" add: tokens " SCRN( " add: tokens " PDL" add: tokens " POS" add: tokens " SQR" add: tokens " RND" add: tokens " LOG" add: tokens " EXP" add: tokens " COS" add: tokens " SIN" add: tokens " TAN" add: tokens " ATN" add: tokens " PEEK" add: tokens " LEN" add: tokens " STR$" add: tokens " VAL" add: tokens " ASC" add: tokens " CHR$" add: tokens " LEFT$" add: tokens " RIGHT$" add: tokens " MID$ " add: tokens ; \ ) \ ------------------------------------ \ Fetch the text for a token \ ------------------------------------ : @token { n -- addr len t | f } n 128 - 0 >= ( bug fix! ) n 128 - limit: tokens < and if n 128 - at: tokens TRUE else FALSE then ; \ ------------------------------------ \ Put a character in the output buffer \ ------------------------------------ : >buffer ( char -- ) outbuff buffIndex + c! buffIndex 1+ -> buffIndex ; \ ------------------------------------ \ copy a string to the output buffer \ ------------------------------------ : str>buffer { addr len -- } addr len + addr DO i c@ >buffer LOOP ; \ ------------------------------- \ Write the output buffer to disk \ ------------------------------- : writeBuffer ( -- ) outbuff buffIndex write: output dup 0= if drop else .error then ; \ ----------------- \ Disk access words \ ----------------- \ \ Translate track,sector or block number into an absolute \ address within the disk image. Uses image_order and image_type \ settings to calculate the correct byte. \ DOS disk in DOS order : >dos_dos { trk sec -- address } trk 16 * 256 * sec 256 * + buff + ; \ ProDOS disk in DOS order \ maps for which part of the block is in which sector 0 Value p_buff : p_arrays ( -- ) \ setup map arrays and get buffer memory 0 0 to: p_low 13 1 to: p_low 11 2 to: p_low 9 3 to: p_low 7 4 to: p_low 5 5 to: p_low 3 6 to: p_low 1 7 to: p_low 14 0 to: p_high 12 1 to: p_high 10 2 to: p_high 8 3 to: p_high 6 4 to: p_high 4 5 to: p_high 2 6 to: p_high 15 7 to: p_high 520 newPtr -> p_buff ; : >dos_pdos { block \ trk rel.b -- address } block 8 / -> trk block 8 mod -> rel.b trk rel.b at: p_low >dos_dos p_buff 256 cmove \ low part trk rel.b at: p_high >dos_dos p_buff 256 + 256 cmove \ high part p_buff \ proper block is in here ; \ ProDOS disk in ProDOS order : >pdos_pdos { block -- address } block 512 * buff + ; \ DOS disk in ProDOS order \ maps: : d_arrays ( -- ) \ setup the map and offset arrays 0 0 to: d_map 7 1 to: d_map 6 2 to: d_map 6 3 to: d_map 5 4 to: d_map 5 5 to: d_map 4 6 to: d_map 4 7 to: d_map 3 8 to: d_map 3 9 to: d_map 2 10 to: d_map 2 11 to: d_map 1 12 to: d_map 1 13 to: d_map 0 14 to: d_map 7 15 to: d_map 0 0 to: d_half 0 1 to: d_half 256 2 to: d_half 0 3 to: d_half 256 4 to: d_half 0 5 to: d_half 256 6 to: d_half 0 7 to: d_half 256 8 to: d_half 07 9 to: d_half 256 10 to: d_half 0 11 to: d_half 256 12 to: d_half 0 13 to: d_half 256 14 to: d_half 256 15 to: d_half ; : >pdos_dos { trk sec -- address } trk 8 * sec at: d_map + 512 * sec at: d_half + buff + ; \ ------------------- \ DOS 3.3 order image \ ------------------- : >dos33 ( trk sec | block -- address ) image_type ( what is it? ) CASE DOS33 OF >dos_dos ENDOF \ DOS 3.3 PRODOS OF >dos_pdos ENDOF \ ProDOS PASCAL OF >dos_pdos ENDOF \ Pascal ENDCASE ; \ ------------------ \ ProDOS order image \ ------------------ : >pdos ( block -- address ) image_type CASE DOS33 OF >pdos_dos ENDOF \ DOS 3.3 PRODOS OF >pdos_pdos ENDOF \ ProDOS PASCAL OF >pdos_pdos ENDOF \ Pascal ENDCASE ; \ ---------------- \ Universal access \ ---------------- : >addr ( trk sec | block -- address ) image_order ( how is it stored? ) CASE PRODOS OF >pdos ENDOF DOS33 OF >dos33 ENDOF ENDCASE ; \ ---------------------------- \ Set the image type and order \ ---------------------------- : setType ( type order -- ) -> image_order -> image_type ; \ Section: DOS 3.3 Images \ ========================================================== \ DOS 3.3 \ ========================================================== \ ---------------------------- \ Display DOS 3.3 file type \ ---------------------------- : .ftype ( type -- ) CASE 0 OF ." T " ENDOF 1 OF ." I " ENDOF 2 OF ." A " ENDOF 4 OF ." B " ENDOF 8 OF ." S " ENDOF 16 OF ." R " ENDOF 32 OF ." A " ENDOF 64 OF ." B " ENDOF ENDCASE ; \ ---------------------------- \ Display DOS 3.3 file size \ ---------------------------- : .fsize ( sectors -- ) dup 99 > if 3 .r else dup 9 > if ." 0" 2 .r else ." 00" 1 .r then then space ; \ ---------------------- \ Catalog a DOS 3.3 disk \ ---------------------- : dcat { \ offset foffset nxttrk nxtsec c -- } cr 17 15 >addr -> offset offset 1+ c@ -> nxttrk \ next link in catalog chain offset 2+ c@ -> nxtsec 0 -> c \ file count BEGIN 7 0 do offset $ 0b 35 i * + + -> foffset \ calc file offset foffset c@ $ ff <> foffset c@ 0 <> and if \ skip deleted and empty files foffset 2+ c@ \ get file type dup $ 80 and 0= 0= if ." *" ( locked file ) else ." " then $ 7F and .ftype \ and display it foffset $ 21 + c@ foffset $ 22 + c@ 256 * + \ file size in sectors .fsize foffset $ 21 + foffset 3+ do i c@ $ 7F and emit \ turn off high bit loop cr c 19 > if key drop 0 -> c then \ pause c 1+ -> c then loop nxttrk 0 <> if nxttrk nxtsec >addr -> offset offset 1+ c@ -> nxttrk offset 2+ c@ -> nxtsec then nxttrk 0 = until cr ; \ ------------------------------------------ \ Find a DOS 3.3 file in the catalog by name \ ------------------------------------------ 0 value typ : DLOOKUP { \ offset foffset nxttrk nxtsec trk sec -- trk sec type t | f } \ look it up in the catalog 17 15 >addr -> offset offset 1+ c@ -> nxttrk \ next link in catalog chain offset 2+ c@ -> nxtsec 0 -> trk 0 -> sec BEGIN 7 0 do offset $ 0b 35 i * + + -> foffset \ calc file offset foffset c@ $ ff <> foffset c@ 0 <> and if \ skip deleted and empty files clear: s foffset $ 21 + foffset 3+ do i c@ $ 7F and +: s loop uc: t drop drop \ make sure uppercase uc: s drop drop start: s get: t indexOf: s if 0= if foffset c@ -> trk foffset 1+ c@ -> sec foffset 2+ c@ $ 7F and -> typ then then then loop nxttrk 0 <> if nxttrk nxtsec >addr -> offset offset 1+ c@ -> nxttrk offset 2+ c@ -> nxtsec then nxttrk 0 = until trk 0= if FALSE else trk sec typ TRUE then ; \ ------------------------------------------- \ Build a list of DOS 3.3 filenames in fnames \ ------------------------------------------- : dfiles { \ offset foffset nxttrk nxtsec trk sec -- } clear: fnames \ clear existing list 17 15 >addr -> offset offset 1+ c@ -> nxttrk \ next link in catalog chain offset 2+ c@ -> nxtsec 0 -> trk 0 -> sec BEGIN 7 0 do offset $ 0b 35 i * + + -> foffset \ calc file offset foffset c@ $ ff <> foffset c@ 0 <> and if \ skip deleted and empty files clear: g foffset $ 21 + foffset 3+ do i c@ $ 7F and +: g loop uc: g drop drop \ make sure uppercase get: g add: fnames \ and add to the list then loop nxttrk 0 <> if nxttrk nxtsec >addr -> offset offset 1+ c@ -> nxttrk offset 2+ c@ -> nxtsec then nxttrk 0 = until ; \ ---------------------------------------------- \ Text File: copy a sector to the output buffer \ ---------------------------------------------- : textOut { trk sec \ a -- } trk sec >addr -> a 256 0 DO a c@ dup 0= if drop 1000 else $ 7F and >buffer 1 then a 1+ -> a +LOOP ; \ ---------------------------- \ Copy a DOS 3.3 text file \ ---------------------------- : tdcopy { tsTrk tsSec \ offset nxttrk nxtsec n -- } tsTrk tsSec >addr -> offset offset 1+ c@ -> nxttrk offset 2+ c@ -> nxtsec 0 -> buffIndex BEGIN offset 12 + -> n \ pairs start 12 bytes into sector BEGIN n c@ 0 <> \ while not done and not outside the sector n offset - $ FF < and WHILE n c@ n 1+ c@ textOut n 2+ -> n REPEAT nxttrk 0 <> if nxttrk nxtsec >addr -> offset offset 1+ c@ -> nxttrk offset 2+ c@ -> nxtsec then nxttrk 0 = UNTIL writeBuffer \ save output on disk ; \ ---------------------------------- \ Put a character in the temp buffer \ ---------------------------------- : >temp ( char -- ) \ tempbuff tempIndex + c! tempIndex 1+ -> tempIndex ; \ -------------------------------- \ Copy a sector to the temp buffer \ -------------------------------- : fileOut { trk sec \ a -- } trk sec >addr -> a 256 0 DO a c@ >temp a 1+ -> a LOOP ; \ ---------------------------------- \ Copy a file to the temp buffer \ ---------------------------------- : filecopy { tsTrk tsSec \ offset nxttrk nxtsec n -- } tsTrk tsSec >addr -> offset offset 1+ c@ -> nxttrk offset 2+ c@ -> nxtsec 0 -> tempIndex BEGIN offset 12 + -> n \ pairs start 12 bytes into sector BEGIN n c@ 0 <> \ while not done and not outside the sector n offset - $ FF < and WHILE n c@ n 1+ c@ fileOut \ save file in temp buffer n 2+ -> n REPEAT nxttrk 0 <> if nxttrk nxtsec >addr -> offset offset 1+ c@ -> nxttrk offset 2+ c@ -> nxtsec then nxttrk 0 = UNTIL ; \ -------------------------------------------------------------------- \ Output an Applesoft program from temp buffer to output buffer \ -------------------------------------------------------------------- : basicOut { \ n length pos end -- } 0 -> buffIndex tempbuff c@ tempbuff 1+ c@ 256 * + -> length \ program length tempbuff length + -> end \ ending memory address tempbuff 2+ -> n \ starting memory address BEGIN n end 1- < WHILE n 2+ -> n \ skip link n c@ n 1+ c@ 256 * + \ line number 0 <# #s #> str>buffer 32 >buffer \ and output it n 2+ -> n \ move to code BEGIN n c@ 0 <> WHILE n c@ dup 127 > if @token if str>buffer then \ output token text else dup 31 > if >buffer else drop then \ output character then \ (drop control characters) n 1+ -> n REPEAT 13 >buffer \ end of line n 1+ -> n \ move to next line REPEAT ; \ ---------------------------------------------------------------- \ copy a DOS 3.3 Applesoft file to a disk file substituting tokens \ ---------------------------------------------------------------- : adcopy { tsTrk tsSec -- } tsTrk tsSec filecopy \ put file in temp buffer basicOut \ process the file writeBuffer \ write the outbuff to disk ; \ ---------------------------------- \ copy a binary file to a disk file \ ---------------------------------- : bdcopy { tsTrk tsSec \ n -- } tsTrk tsSec filecopy \ put file in temp buffer tempbuff 2+ c@ tempbuff 3+ c@ 256 * + 1+ -> n \ image length tempbuff 4+ n write: output \ write image to a file dup 0= if drop else .error then ; \ -------------------------------------------------- \ copy an I, S, R, A*, or B* file to a disk file \ -------------------------------------------------- : vdcopy { tsTrk tsSec -- } tsTrk tsSec filecopy \ put file in temp buffer tempbuff tempIndex write: output \ write verbatim image to disk dup 0= if drop else .error then ; \ --------------------------------------- \ Copy a DOS 3.3 file to a real disk file \ --------------------------------------- : printName ( -- ) get: t type ." --> " get: outname type cr ; : dcopy { \ trk sec typ -- } dlookup if -> typ -> sec -> trk \ T/S list starts here printName \ output file name get: outname name: output \ output file delete: output drop create: output dup 0= if drop \ set output file type typ CASE 0 OF drop drop ENDOF 2 OF drop drop ENDOF ENDCASE set: output trk sec typ 0= if tdcopy else \ copy a text file typ 2 = if adcopy else \ copy an Applesoft file typ 4 = if bdcopy else \ copy a binary file vdcopy then then then \ all other files close: output drop else .error then else ." File not found." cr then ; \ ------------------------------------------ \ Replace "bad" characters in DOS filenames \ ------------------------------------------ : fixBadChars { addr len -- } clear: p \ put it in here addr len + addr DO i c@ dup 32 < if drop 32 else dup ascii : = if drop ascii ; then then +: p LOOP ; \ ---------------------- \ Remove trailing spaces \ ---------------------- : filterP { \ addr len len' c -- } lock: p get: p -> len -> addr len -> len' 0 -> c addr 1- addr len + 1- DO i c@ 32 <> if len c - -> len' leave then c 1+ -> c -1 +loop addr len' put: p unlock: p ; \ ------------------ \ Copy all DOS files \ ------------------ : dwildAll { -- } dfiles \ get a list of file names limit: fnames 0 do i at: fnames fixBadChars \ replace control and ":" filterP \ remove trailing spaces get: p put: outname \ Mac filename i at: fnames put: t \ DOS 3.3 filename dcopy \ copy the file loop ; \ --------------------------------------- \ Split w into parts \ --------------------------------------- sArray ww \ parts of the template w : parseW { -- } start: w uc: w drop drop \ uppercase w clear: ww \ clear old ascii * putChar: ww \ delimit character get: w place: ww \ split into strings ; \ --------------------------------------- \ Does filename in s match template in w? \ --------------------------------------- : match? { \ m -- t|f } limit: ww 1 = IF \ wildcard at end 0 at: ww put: w start: w get: w start: p indexOf: p IF drop TRUE ELSE FALSE THEN ELSE limit: ww 1 > IF \ wildcard 0 at: ww dup -> m get: p drop m s= \ does first part match? 1 at: ww dup -> m get: p m - + m s= \ second part? and ELSE FALSE THEN THEN ; \ -------------------------------- \ Copy DOS files based on wildcard \ -------------------------------- : dwild { -- } " *" get: w s= IF dwildAll \ copy all files ELSE dfiles \ get a list of file names parseW \ parse template string limit: fnames 0 do i at: fnames fixBadChars \ replace control and ":" filterP \ remove trailing spaces match? if get: p put: outname \ matches wildcard i at: fnames put: t \ so copy the file dcopy then loop THEN ; \ -------------------------------- \ Universal DOS copy file in w \ -------------------------------- : DOScopy { -- } start: w uc: w drop drop \ uppercase wildcard start: w ascii * charOf: w IF drop dwild ELSE \ '*' present get: w fixBadChars \ single filename filterP get: p put: outname get: w put: t dcopy THEN ; \ Section: ProDOS Images \ ========================================================== \ ProDOS \ ========================================================== \ ----------------- \ Get the disk name \ ----------------- : volumeName { \ offset -- addr len t|f } ( block ) 2 >addr -> offset offset 4+ c@ $ F0 and $ F0 = if \ a valid volume name offset 5 + offset 4+ c@ $ 0F and TRUE else ." Not a valid ProDOS volume" cr FALSE then ; \ ------------------- \ Print creation date \ ------------------- : .month { m -- } m CASE 1 OF ." JAN" ENDOF 2 OF ." FEB" ENDOF 3 OF ." MAR" ENDOF 4 OF ." APR" ENDOF 5 OF ." MAY" ENDOF 6 OF ." JUN" ENDOF 7 OF ." JUL" ENDOF 8 OF ." AUG" ENDOF 9 OF ." SEP" ENDOF 10 OF ." OCT" ENDOF 11 OF ." NOV" ENDOF 12 OF ." DEC" ENDOF ENDCASE ; : .pdate { a b \ m d y -- } \ print ProDOS date ( MMMDDDDD YYYYYYYM = format ) b 2/ -> y \ year a $ 1F and -> d \ day a 2/ 2/ 2/ 2/ 2/ -> m \ month b 1 and if m 8 + -> m then d .p ." -" m .month ." -" y 2 .r ; \ ----------------- \ ProDOS file type \ ----------------- : .pftype { typ -- } \ print a ProDOS file type typ $ 01 = if ." BAD" else typ $ 04 = if ." TXT" else typ $ 06 = if ." BIN" else typ $ 0F = if ." DIR" else typ $ 19 = if ." ADB" else typ $ 1A = if ." AWP" else typ $ 1B = if ." ASP" else typ $ EF = if ." PAS" else typ $ F0 = if ." CMD" else typ $ FA = if ." INT" else typ $ FB = if ." IVR" else typ $ FC = if ." BAS" else typ $ FD = if ." VAR" else typ $ FE = if ." REL" else typ $ FF = if ." SYS" else ." $" hex typ 2 .r decimal then then then then then then then then then then then then then then then ; \ --------------------------------------- \ Catalog a ProDOS disk \ --------------------------------------- : pcat { \ offset foffset c done? -- } cr volumeName if type cr cr 2 >addr -> offset FALSE -> done? \ true when end reached 0 -> c \ file count BEGIN 13 1 do offset 4 39 i * + + -> foffset \ calc file offset foffset c@ $ F0 and 0 <> if \ skip deleted files foffset $ 1E + c@ $ C2 and $ C2 = if ." *" else ." " then \ file locked? foffset c@ $ 0F and dup \ get length of name foffset 1+ swap type \ type filename 18 swap - 0 do space loop \ get to the right column foffset $ 10 + c@ .pftype \ ProDOS file type foffset $ 13 + c@ foffset $ 14 + c@ 256 * + 4 .r ." " foffset $ 18 + c@ foffset $ 19 + c@ .pdate \ date created space foffset $ 1B + c@ .p \ time created ascii : emit foffset $ 1A + c@ .p cr c 19 > if key drop 0 -> c then \ pause c 1+ -> c then loop offset 2+ c@ offset 3+ c@ 256 * + dup 0= if drop TRUE -> done? else >addr -> offset then done? until cr then ; \ --------------------------------------- \ Lookup a ProDOS file by name \ --------------------------------------- : plookup { \ offset foffset c done? found? -- iblk ftype stype fsize t | f } 2 >addr -> offset FALSE -> done? \ true when end reached FALSE -> found? BEGIN 13 1 do offset 4 39 i * + + -> foffset \ calc file offset foffset c@ $ F0 and 0 <> if \ skip deleted files foffset c@ $ 0F and \ get length of name foffset 1+ swap put: s \ get the filename start: s uc: s drop drop \ uppercase names start: t uc: t drop drop get: s get: t s= IF foffset $ 11 + c@ \ found the right file foffset $ 12 + c@ 256 * + \ index block foffset $ 10 + c@ \ file type foffset c@ 2/ 2/ 2/ 2/ \ storage type foffset $ 15 + c@ \ file size, bytes foffset $ 16 + c@ 256 * foffset $ 17 + c@ 65536 * + + TRUE -> found? THEN then loop offset 2+ c@ offset 3+ c@ 256 * + dup 0= if drop TRUE -> done? else >addr -> offset then done? until found? ; \ ------------------------------------------ \ Build a list of ProDOS filenames in fnames \ ------------------------------------------ : pfiles { \ offset foffset c done? -- } clear: fnames 2 >addr -> offset FALSE -> done? \ true when end reached BEGIN 13 1 do offset 4 39 i * + + -> foffset \ calc file offset foffset c@ $ F0 and 0 <> if \ skip deleted files foffset c@ $ 0F and \ get length of name foffset 1+ swap put: s \ get the filename start: s uc: s drop drop \ uppercase names get: s add: fnames \ add to the list then loop offset 2+ c@ offset 3+ c@ 256 * + dup 0= if drop TRUE -> done? else >addr -> offset then done? until ; \ -------------------------------- \ Copy a block to the temp buffer \ -------------------------------- : pblkOut { blk \ a -- } blk >addr -> a 512 0 DO a c@ >temp a 1+ -> a LOOP ; \ ------------------------------------- \ Copy a ProDOS file to the temp buffer \ ------------------------------------- : pfilecpy { iblk styp \ offset nxtblk n -- } 0 -> tempIndex \ reset memory pointer styp CASE 1 OF iblk pblkOut \ seedling file (1 block) ENDOF 2 OF \ sapling file (1 index block) 256 0 DO iblk >addr -> offset ( get base address of index ) offset i + c@ offset i + $ 100 + c@ 256 * + ( current block to copy ) dup 0 <> IF pblkOut ELSE drop THEN LOOP ENDOF 3 OF \ tree file (multiple index blocks) ." Tree files not available in this release. :(" cr ENDOF 13 OF ." Subdirectories not available in this release. :(" cr ENDOF \ subdirectory ENDCASE ; \ ------------------ \ Text file (ProDOS) \ ------------------ : tpcopy { iblk styp fsize -- } iblk styp pfilecpy \ put file in temp buffer fsize 0 do tempbuff i + c@ $ 7F and \ turn off high bit tempbuff i + c! loop tempbuff fsize write: output \ write the bytes to disk dup 0= if drop else .error then ; \ ----------------------------- \ Process ProDOS Applesoft file \ ----------------------------- : basic2Out { fsize \ n length pos end -- } 0 -> buffIndex fsize -> length \ program length tempbuff length + -> end \ ending memory address tempbuff -> n \ starting memory address BEGIN n end 3 - < WHILE n 2+ -> n \ skip link n c@ n 1+ c@ 256 * + \ line number 0 <# #s #> str>buffer 32 >buffer \ and output it n 2+ -> n \ move to code BEGIN n c@ 0 <> WHILE n c@ dup 127 > if @token if str>buffer then \ output token text else dup 31 > if >buffer else drop then \ output character then \ (drop control characters) n 1+ -> n REPEAT 13 >buffer \ end of line n 1+ -> n \ move to next line REPEAT ; \ ----------------------- \ Applesoft file (ProDOS) \ ----------------------- : apcopy { iblk styp fsize -- } iblk styp pfilecpy \ put file in temp buffer fsize basic2Out \ process file writeBuffer \ save file ; \ -------------------- \ Binary file (ProDOS) \ -------------------- : bpcopy { iblk styp fsize -- } iblk styp pfilecpy \ put file in temp buffer tempbuff fsize write: output \ write proper number of bytes dup 0= if drop else .error then ; \ ---------------------- \ Verbatim copy (ProDOS) \ ---------------------- : vpcopy { iblk styp fsize -- } iblk styp pfilecpy \ put file in temp buffer tempbuff tempIndex write: output \ write verbatim image to disk dup 0= if drop else .error then ; \ ------------------------------------- \ Copy a ProDOS file \ ------------------------------------- : pcopy { \ styp ftyp iblk fsize -- } plookup if -> fsize -> styp -> ftyp -> iblk \ size, storage, type, index blk printName \ output file name get: outname name: output \ output file delete: output drop create: output dup 0= if drop \ set output file type ftyp CASE 4 OF drop drop ENDOF \ TXT 239 OF drop drop ENDOF \ PAS 252 OF drop drop ENDOF \ BAS ENDCASE set: output iblk styp fsize ftyp 4 = if tpcopy else \ copy a text file ftyp 239 = if tpcopy else \ Pascal text file ftyp 252 = if apcopy else \ copy an Applesoft file ftyp 6 = if bpcopy else \ copy a binary file ftyp 255 = if bpcopy else \ SYS file vpcopy then then then then then \ all other files close: output drop else .error then else ." File not found." cr then ; \ --------------------- \ Copy all ProDOS files \ --------------------- : pwildAll { -- } pfiles \ get a list of file names limit: fnames 0 do i at: fnames put: p \ replace control and ":" filterP \ remove trailing spaces get: p put: outname \ Mac filename i at: fnames put: t \ DOS 3.3 filename pcopy \ copy the file loop ; \ ----------------------------------- \ Copy ProDOS files based on wildcard \ ----------------------------------- : pwild { -- } " *" get: w s= IF pwildAll \ copy all files ELSE pfiles \ get a list of file names parseW \ parse template string limit: fnames 0 do i at: fnames put: p \ replace control and ":" filterP \ remove trailing spaces match? if get: p put: outname \ matches wildcard i at: fnames put: t \ so copy the file pcopy then loop THEN ; \ -------------------------------- \ Universal ProDOS copy file in w \ -------------------------------- : PRODOScopy { -- } start: w uc: w drop drop \ uppercase wildcard start: w ascii * charOf: w IF drop pwild ELSE \ '*' present get: w put: p \ single filename filterP get: p put: outname get: w put: t pcopy THEN ; \ Section: Pascal Images \ ========================================================== \ Pascal \ ========================================================== \ Pascal Directory Structure: \ \ Blocks 2 - 5 are the directory, enties do not fit \ evenly within the blocks. Blocks are same as ProDOS. \ \ Block 2: \ \ $02-03: block of start of data (lo/hi = 6) \ $06 : length of volume name \ $07-0D: volume name (7-bit ASCII) \ $0E-0F: volume size in blocks (lo/hi = 280) \ $10-11: ??? \ $14-15: date volume last modified? (see format below) \ $1A-33: 1st file entry \ $34-..: 2nd file entry \ etc.. each entry is 26 ($1A) bytes long \ \ File Entry: \ \ $00-01: starting block (1st block of the file) \ $02-03: ending block + 1 \ $04-05: file type (lo/hi). 2 = CODE, 3 = TEXT, 5 = DATA \ $06 : length of filename \ $07-15: filename (7-bit ASCII) \ $16-17: number bytes used in last block (lo/hi), usually 512 ($200) \ $18-19: date file created (modified?) \ --> $18: D3 D2 D1 D0 M3 M2 M1 M0 \ $19: Y6 Y5 Y4 Y3 Y2 Y1 Y0 D4 (bits) \ \ ------------------ \ Get a command line \ ------------------ : loadDirectory 2 >addr tempBuff 512 cmove 3 >addr tempBuff 512 + 512 cmove 4 >addr tempBuff 1024 + 512 cmove 5 >addr tempBuff 1536 + 512 cmove ; \ ---------------------- \ Print Pascal file type \ ---------------------- : .pastype { typ -- } typ CASE 2 OF ." Codefile" ENDOF 3 OF ." Textfile" ENDOF 5 OF ." Datafile" ENDOF ENDCASE ; \ ------------------- \ Print Pascal month \ ------------------- ( vanity.. could have used .month above) : .pmonth { m -- } m CASE 1 OF ." Jan" ENDOF 2 OF ." Feb" ENDOF 3 OF ." Mar" ENDOF 4 OF ." Apr" ENDOF 5 OF ." May" ENDOF 6 OF ." Jun" ENDOF 7 OF ." Jul" ENDOF 8 OF ." Aug" ENDOF 9 OF ." Sep" ENDOF 10 OF ." Oct" ENDOF 11 OF ." Nov" ENDOF 12 OF ." Dec" ENDOF ENDCASE ; \ ------------------------------ \ Print date Pascal file created \ ------------------------------ : .pasdate { p1 p2 \ m d y -- } p2 2/ -> y \ year p1 $ 0F and -> m \ month p1 2/ 2/ 2/ 2/ -> d p2 1 and if d 16 + -> d then \ day d 2 .r ." -" m .pmonth ." -" y 2 .r ; \ --------------------- \ Catalog a Pascal disk \ --------------------- : pascat { \ b f eb c -- } loadDirectory \ load the directory blocks into tempBuff tempBuff -> b 0 -> c b 7 + b 6 + c@ type ascii : emit cr \ volume name 77 0 DO b 26 i * 26 + + -> f \ file entry offset f 6 + c@ 0 <> IF \ skip deleted and empty files f 7 + f 6 + c@ type \ filename 19 f 6 + c@ - 0 do space loop \ pad f 2+ c@ f 3 + c@ 256 * + f c@ f 1+ c@ 256 * + - 3 .r \ size in blocks space space space f $ 18 + c@ f $ 19 + c@ .pasdate \ date space space space f c@ f 1+ c@ 256 * + 3 .r \ starting block space space space f $ 16 + c@ f $ 17 + c@ 256 * + 3 .r \ bytes in last block space space space f 4 + c@ .pastype cr \ file type f 2+ c@ f 3 + c@ 256 * + -> eb c 1+ -> c c 20 > if 0 -> c key drop then \ pause THEN LOOP ." < UNUSED > " \ free space 280 eb - 3 .r ." " eb 3 .r cr ; \ ------------------------ \ Lookup a Pascal filename \ ------------------------ : paslookup { \ b f found? -- sblk eblk typ sz t | f } loadDirectory \ load the directory blocks into tempBuff tempBuff -> b FALSE -> found? 77 0 DO b 26 i * 26 + + -> f \ file entry offset f 6 + c@ 0 <> IF \ skip deleted and empty files f 7 + f 6 + c@ put: g \ filename start: g uc: g drop drop start: t uc: t drop drop get: g get: t s= if f c@ f 1+ c@ 256 * + \ starting block f 2+ c@ f 3 + c@ 256 * + \ ending block+1 f 4 + c@ \ type f $ 16 + c@ f $ 17 + c@ 256 * + \ size in last block TRUE -> found? then THEN LOOP found? IF TRUE ELSE FALSE THEN ; \ --------------------------------------- \ Put a list of Pascal filename in fnames \ --------------------------------------- : pasfiles { \ b f -- } clear: fnames loadDirectory \ load the directory blocks into tempBuff tempBuff -> b 77 0 DO b 26 i * 26 + + -> f \ file entry offset f 6 + c@ 0 <> IF \ skip deleted and empty files f 7 + f 6 + c@ put: g \ filename start: g uc: g drop drop get: g add: fnames \ add it THEN LOOP ; \ ------------------ \ Copy a Text file \ ------------------ : tpascopy { sblk eblk sz \ a c -- } 0 -> buffIndex eblk sblk 2+ DO \ ignore first two blocks i >addr -> a a 512 + a DO i c@ -> c c 13 = if c >buffer 1 else \ return c 31 > if c >buffer 1 else \ valid character, copy c 16 = if \ DLE char i a 511 + <> if \ not at end of block i 1+ c@ 32 > if i 1+ c@ 32 - 0 DO 32 >buffer \ output proper number of spaces LOOP then then 2 \ skip ahead else 1 then then then \ control character, skip +LOOP LOOP writeBuffer \ save file ; \ ------------------------ \ Copy a Data or Code file \ ------------------------ : dpascopy { sblk eblk sz -- } eblk sblk DO i >addr outBuff i sblk - 512 * + 512 cmove \ put a block in buffer LOOP eblk sblk - 512 * 512 sz - - -> buffIndex \ length writeBuffer \ write to disk ; \ ------------------ \ Copy a Pascal file \ ------------------ : pascopy { \ sblk eblk typ sz -- } paslookup if -> sz -> typ -> eblk -> sblk printName \ output file name get: outname name: output \ output file delete: output drop create: output dup 0= if drop \ set output file type typ 3 = IF drop drop THEN set: output sblk eblk sz typ 2 = if dpascopy then \ Code file typ 3 = if tpascopy then \ Text file typ 5 = if dpascopy then \ Data file close: output drop else .error then else ." File not found." cr then ; \ --------------------- \ Copy all Pascal files \ --------------------- : paswildAll { -- } pasfiles \ get a list of file names limit: fnames 0 do i at: fnames put: outname \ Mac filename i at: fnames put: t \ Pascal filename pascopy \ copy the file loop ; \ ----------------------------------- \ Copy Pascal files based on wildcard \ ----------------------------------- : paswild { -- } " *" get: w s= IF paswildAll \ copy all files ELSE pasfiles \ get a list of file names parseW \ parse template string limit: fnames 0 do i at: fnames put: p \ replace control and ":" match? if get: p put: outname \ matches wildcard i at: fnames put: t \ so copy the file pascopy then loop THEN ; \ -------------------------------- \ Universal Pascal copy file in w \ -------------------------------- : PASCALcopy { -- } start: w uc: w drop drop \ uppercase wildcard start: w ascii * charOf: w IF drop paswild ELSE \ '*' present get: w put: p \ single filename get: p put: outname get: w put: t pascopy THEN ; \ Section: Command Line Interface \ ========================================================== \ Command Line Interface \ ========================================================== \ Objects sArray cmd \ a command line \ Allowed commands: \ copy | cp = copy files to Mac \ cat | dir | ls | catalog = catalog image \ help | ? = print help info \ load = load a disk image \ quit | bye | exit = exit program \ stats = image name, type, and order \ ------------------ \ Get a command line \ ------------------ 0 Value cbuff : initCmd ( -- ) 512 newptr -> cbuff ; : length { addr -- len } addr 512 + addr DO i c@ 0= IF i addr - leave THEN LOOP ; : getCmd { -- } clear: cmd \ clear old values ascii ` putchar: cmd \ setup delimiter (backquote) ." ]" cbuff 80 expect \ get a command line cbuff cbuff length place: cmd \ save the string uc: cmd drop drop \ and make it uppercase ; \ --------------------------------------- \ Universal catalog \ --------------------------------------- : cat ( -- ) image? IF image_type CASE DOS33 OF dcat ENDOF PRODOS OF pcat ENDOF PASCAL OF pascat ENDOF ENDCASE ELSE ." No image file in memory." cr THEN ; \ ----------- \ Help screen \ ----------- : helpScreen ( -- ) cr ." Command Function" cr ." ----------------------------------------------------------" cr ." HELP, ? Print this screen" cr ." CAT, DIR, LS List files" cr ." SET `type`order Set image type & order (no spaces)" cr ." STATS Print image file info" cr ." COPY, CP `filename` Copy `filename` from image" cr ." LOAD Load an image file" cr ." BYE, QUIT, EXIT Exit program" cr cr ; \ -------------- \ Universal Copy \ -------------- : copy ( -- ) image? IF 1 at: cmd put: w \ transfer filename image_type CASE DOS33 OF DOScopy ENDOF \ DOS 3.3 image type PRODOS OF PRODOScopy ENDOF \ ProDOS image type PASCAL OF PASCALcopy ENDOF \ Pascal image type ENDCASE ELSE ." No image file in memory." cr THEN ; \ ----------- \ Image stats \ ----------- : stats ( -- ) image? IF ." Image name : " getName: disk type cr ." type : " image_type CASE DOS33 OF ." DOS 3.3" ENDOF PRODOS OF ." ProDOS" ENDOF PASCAL OF ." Pascal" ENDOF ENDCASE cr ." order: " image_order CASE DOS33 OF ." DOS 3.3" ENDOF PRODOS OF ." ProDOS" ENDOF ENDCASE cr ELSE ." No image file in memory." cr THEN ; \ ----------------- \ Get an image file \ ----------------- : loadImage ( -- ) readFile IF TRUE -> image? ELSE FALSE -> image? ." Image not loaded." cr THEN ; \ ----------------- \ Get an image file \ ----------------- : setImage ( -- ) image? IF DOS33 \ default image type 1 at: cmd " PRODOS" s= IF drop PRODOS THEN 1 at: cmd " PASCAL" s= IF drop PASCAL THEN -> image_type DOS33 \ default image order 2 at: cmd " PRODOS" s= IF drop PRODOS THEN -> image_order ELSE ." Image not loaded." cr THEN ; \ --------------------------------------- \ Command loop \ --------------------------------------- : ?? { addr len -- t|f } addr len 0 at: cmd drop len s= ; : cmdLoop { -- } BEGIN getCmd " HELP" ?? IF helpScreen THEN " ?" ?? IF helpScreen THEN " SET" ?? IF setImage THEN " COPY" ?? IF copy THEN " CP" ?? IF copy THEN " CAT" ?? IF cat THEN " DIR" ?? IF cat THEN " LS" ?? IF cat THEN " LOAD" ?? IF loadImage THEN " STATS" ?? IF stats THEN " QUIT" ?? IF bye THEN " EXIT" ?? IF bye THEN " BYE" ?? IF bye THEN 3 2 < UNTIL ; \ ----------- \ Init things \ ----------- : setup p_arrays \ ProDOS map arrays d_arrays \ DOS map arrays initCmd \ reserve cmd line memory loadTokens \ setup tokens initMemory \ reserve image memory new: s \ reserve room for strings new: w new: ww new: outname new: command new: fnames new: cmd new: t new: p new: g 0 -> image? ; \ Section: Yerk Application Code \ ========================================================== \ Yerk Application Code \ ========================================================== \ about box 2 Dialog aboutDialog \ about box, no buttons just click to exit 2 'cfas null null actions: aboutDialog 500 init: aboutDialog : aboutI2F getNew: aboutDialog \ show the dialog modal: aboutDialog close: aboutDialog ; \ Menus 2 AppleMenu ApplMenu \ menu objects 2 Menu FileMenu 8 Menu EditMenu 2 'cfas aboutI2F null 132 put: ApplMenu 2 'cfas loadImage bye 128 put: FileMenu 8 'cfas null null null null null null null null 129 put: EditMenu : myMenus \ setup menus clear: menubar \ erase old draw: menubar \ clear the bar release: applemen \ eliminate old Apple menu getNew: ApplMenu \ load the menus getNew: FileMenu getNew: EditMenu ApplMenu FileMenu EditMenu 3 init: menubar ; : initialize ( -- ) \ " image2file12a.rsrc" openresfile \ for menus and about box dialog myMenus \ initialize menus setup \ set things up +curs \ turn on the cursor ; : title ( -- ) cls ." IMAGE2FILE, extract files from Apple II disk images." cr ." Version 1.2a, Ronald T. Kneusel, July 1999, Freeware." cr cr ." (Type '?' for help)" cr cr cr ; \ --------------------------------------- \ Main startup word \ --------------------------------------- 4 'cfas null null null null actions: fwind \ set window actions : startup ( -- ) initialize \ init things title \ show header info cmdLoop \ process commands ; ( debug ) : .hh { n -- } n 16 < if hex ascii 0 emit n 1 .r else hex n 2 .r then decimal ; : dump { \ a -- } >addr -> a a 256 + a DO i a - hex 3 .r decimal ." : " i 16 + i DO i c@ .hh space LOOP ." " i 16 + i DO i c@ dup 31 > if emit else drop ascii . emit then LOOP cr 16 +LOOP cr ; : dump1 { \ a -- } ( second part of a block ) >addr -> a a 512 + a 256 + DO i a - hex 3 .r decimal ." : " i 16 + i DO i c@ .hh space LOOP ." " i 16 + i DO i c@ dup 31 > if emit else drop ascii . emit then LOOP cr 16 +LOOP cr ; \ .\newpage \ Program: Image2File 1.2a \ Author: Ronald T. Kneusel \ Started: July 1996 \ Modified: July 13, 1999 \ Modify By: RTK \ Summary: A program to extract files from Apple II disk images. \ Comments: FORTH \ Uppercase: OFF \ Table of Contents: ON \ Index: ON \ Bold: ON \ Style: ARTICLE