10REM UnZIP stored files from a ZIP
   20REM (C)1999 SPROW
   30:
   40LOMEM=TOP+1028:crctable=(TOP+3)ANDNOT3:REM Don't overwrite the CRC table
   50osfi=&FFDD:osgb=&FFD1:osby=&FFF4
   60DIMmem% 8192,asm% 256,dword 4:PROCasm
   70DIMname 128,namepath 128,extra 128,block% 32:REM Used to hold 'fname' and 'extras'
   80DIMmonth$(12):FORdata%=1TO12:READmonth$(data%):NEXT:REM Text equivalents
   90CLS:PRINT"Zipfile unpacker"':INPUT"ZIP file to open: "source$:F=OPENINsource$
  100IFF=0 THENPRINT'"File not found":END
  110id=FNgetdword:IFid<>&04034B50 THENPRINT'"Not a ZIP file":CLOSE#F:END
  120:
  130tried%=FALSE:gotcdir%=TRUE:ONERRORtried%=TRUE:IFERR=254 THENgotcdir%=FALSE
  140IFNOTtried% THENOSCLI"CDIR $":REM Triggers 'Already exists' or 'Bad command' or nothing
  150ONERROROFF
  160:
  170PRINT"Extract all files (Y/N)?";:REPEAT:key%=GET AND&DF:UNTILkey%=ASC"Y" ORkey%=ASC"N":VDU13
  180IFkey%=ASC"N" THENPRINT"Mode: Prompt before extracting" ELSEPRINT"Mode: Extract all files "
  190confirm%=key%=ASC"N"
  200PTR#F=0
  210REPEAT
  220 id=FNgetdword
  230 IF(id<>&04034B50) AND(id<>&02014B50) THENPRINT'"Corrupt ZIP file":CLOSE#F:END
  240 IFid=&04034B50 THENPROCunpack
  250UNTILid=&02014B50 OREOF#F:REM Start of 'central dir' marker,hence end of files
  260CLOSE#F:PRINT'"Done"
  270END
  280:
  290DEFPROCunpack
  300REM Unpack a file entry
  310PRINT:PTR#F=PTR#F+2:REM Skip the version number
  320flags%=FNgetword:method%=FNgetword
  330PRINT"Last modified: ";:PROCconvchrono(FNgetword,FNgetword)
  340crc%=FNgetdword:csize%=FNgetdword:osize%=FNgetdword:REM Get CRC/compressed/original sizes
  350PRINT"Original size: ";osize%:name$="":namelength%=FNgetword:extras%=FNgetword
  360IFextras%>128 THENPRINT'"Not enough memory for extras field":CLOSE#F:END
  370IFnamelength%>128 THENPRINT'"Name longer than buffer":CLOSE#F:END
  380FORdata%=1TOnamelength%
  390 byte%=BGET#F:IFbyte%=ASC"." THENbyte%=ASC"/" ELSEIFbyte%=ASC"/" THENbyte%=ASC".":REM Swap dots and dir separators
  400 name$=name$+CHR$byte%
  410NEXT
  420IFextras%>0 THENFORdata%=0TO(extras%-1):extra?data%=BGET#F:NEXT:REM Read load/exec addresses
  430IF(flags% AND1)=1 THENPROCskip("File is encrypted"):ENDPROC
  440IFmethod%<>0 THENPROCskip("Don't know how to extract"):ENDPROC
  450IFconfirm% THENPRINT"Extract "name$" (Y/N)?";:REPEAT:key%=GET AND&DF:UNTILkey%=ASC"Y" ORkey%=ASC"N":VDU13 ELSEkey%=ASC"Y"
  460IFkey%=ASC"N" THENPROCskip("By request"):ENDPROC ELSEPRINT"Extracting:"SPC(4);name$
  470IFINSTR(name$,".")>0 THENPROCcreatetree(LEFT$(name$,FNpathname(name$))):REM Check path exists first
  480IFRIGHT$(name$,1)="." ANDosize%=0 THENPTR#F=PTR#F+csize%:ENDPROC:REM Stop at the empty dir
  490out=OPENOUTname$:!crclocal%=0:REM Clear crc
  500REPEAT
  510 IFosize%<8192 THENask%=osize% ELSEask%=8192
  520 block%?0=F:block%!1=mem%:block%!5=ask%
  530 A%=4:X%=block% MOD256:Y%=block% DIV256:CALLosgb
  540 CALLcrccalc,ask%:REM Running total
  550 block%?0=out:block%!1=mem%:block%!5=ask%:osize%=osize%-ask%
  560 A%=2:X%=block% MOD256:Y%=block% DIV256:CALLosgb
  570UNTILosize%=0
  580PRINT"CRC value:     &";~crc%;
  590IFcrc%<>!crclocal% THENPRINT", wrong"'SPC(15)"File may be corrupt!" ELSEPRINT", OK"
  600CLOSE#out
  610IF((!extra AND&FFFF)<>&4341)OR((!extra AND&FFFF)=&4341 AND((!extra AND&FFFF0000)DIV&10000)<>&14) THENPRINTSPC(15)"Ignored attributes":extra!8=&00001900:extra!12=&FFFF8023:extra!16=&00000033
  620extra?6=name MOD256:extra?7=name DIV256:$name=name$+CHR$13:REM Now stamp the file
  630extra!20=extra!16:A%=1:X%=(extra+6)MOD256:Y%=(extra+6)DIV256:CALLosfi
  640ENDPROC
  650:
  660DEFPROCskip(string$):PTR#F=PTR#F+csize%:PRINT"Skipped:"SPC(7);name$'SPC(15)string$:ENDPROC
  670DEFFNgetdword:dword?0=BGET#F:dword?1=BGET#F:dword?2=BGET#F:dword?3=BGET#F:=!dword
  680DEFFNgetword:=BGET#F+(&100*BGET#F)
  690DEFFNpad(V%,L%):=RIGHT$("000"+STR$V%,L%)
  700:
  710REM DOS 16 bit packed binary time is of the form
  720REM MSB.hhhhh.mmmmmm.sssss.LSB,where sssss=seconds/2
  730REM DOS 16 bit packed binary date is of the form
  740REM MSB.yyyyyyymmmmddddd.LSB,where yyyyyyy=year-1980
  750DEFPROCconvchrono(tdata%,ddata%)
  760PRINTFNpad(ddata% MOD32,2);"-";month$((ddata% DIV32)AND&F);"-";1980+(ddata% DIV512);" ";
  770PRINTFNpad(tdata% DIV2048,2);":";FNpad((tdata% DIV32)AND&3F,2);":";FNpad(2*tdata% MOD32,2)
  780ENDPROC
  790:
  800DEFPROCcreatetree(string$)
  810LOCALdata%
  820FORdata%=1TOLENstring$
  830IFMID$(string$,data%,1)="." THENPROCcreatedir(LEFT$(string$,data%-1))
  840NEXT
  850ENDPROC
  860:
  870DEFPROCcreatedir(string$)
  880IFNOTgotcdir% THENENDPROC:REM Maybe it already exists
  890$namepath=string$:block%?0=namepath MOD256:block%?1=namepath DIV256
  900A%=5:X%=block% MOD256:Y%=block% DIV256:A%=(USRosfi)AND&FF
  910IFA%=2 THENENDPROC:REM Dir already exists
  920PRINT"Creating dir:  ";string$;"."
  930IFA%=1 THENPRINT'"Object in the way":CLOSE#F:END
  940OSCLI"CDIR "+string$
  950ENDPROC
  960:
  970DEFFNpathname(string$)
  980LOCALdata%,found%
  990FORdata%=LENstring$ TO1STEP-1
 1000IFMID$(string$,data%,1)="." THENfound%=data%:data%=0
 1010NEXT
 1020=found%
 1030:
 1040DEFPROCasm
 1050bpb%=&600:REM BASIC's parameter block
 1060j1%=&70:j2%=&71:j3%=&72:j4%=&73
 1070A%=0:X%=1:id=(USRosby AND&FF00)DIV256
 1080ONERRORPRINT'"I cannot run this code":END
 1090FORX=0TO2STEP2
 1100P%=asm%
 1110IFid=6 THEN[OPT FNasmarm:] ELSE[OPT FNasm6502:]
 1120[OPTX
 1130.crclookup EQUDcrctable
 1140.crcdata   EQUDmem%
 1150.crclocal% EQUD0:EQUB0
 1160.crclength EQUW0
 1170]
 1180NEXT
 1190ONERROROFF
 1200ENDPROC
 1210:
 1220DEFFNasm6502
 1230[OPTX
 1240.crccalc
 1250\crclength= length of bytes to mix  (j3%)   = mem%+reqd offset
 1260\crclocal%= current CRC             (bpb%+1)->pointer to ask%
 1270\crcdata  ->mem%                    (j1%)   ->crctable+reqd offset
 1280LDAbpb%+1:STAj1%:LDAbpb%+2:STAj2%:\Assume 1 parameter,ask%
 1290LDY#1
 1300.crcsetup
 1310LDAcrcdata,Y:STAj3%,Y:\Point to mem%
 1320LDAcrclocal%+0,Y:EOR#255:STAcrclocal%+0,Y
 1330LDAcrclocal%+2,Y:EOR#255:STAcrclocal%+2,Y
 1340LDA(j1%),Y:STAcrclength,Y:DEY:BPLcrcsetup:\Read ask%
 1350LDAcrclength+1
 1360.crcloop
 1370ORAcrclength+0:BEQcrcdone
 1380JSRcrcdo
 1390INCj3%:BNEcrcnext:INCj4%:\Point to next byte
 1400.crcnext
 1410LDAcrclength+0:SEC:SBC#1:STAcrclength+0
 1420LDAcrclength+1:SBC#0:STAcrclength+1:JMPcrcloop:\See if finished yet
 1430.crcdone
 1440LDY#3
 1450.crcinvert
 1460LDAcrclocal%,Y:EOR#255:STAcrclocal%,Y:DEY:BPLcrcinvert
 1470RTS
 1480.crcdo
 1490LDY#0:STYj2%:LDAcrclocal%+0:EOR(j3%),Y:STAj1%
 1500ASLj1%:ROLj2%:ASLj1%:ROLj2%:\Find offset in crctable
 1510LDA#crctable MOD256:CLC:ADCj1%:STAj1%
 1520LDA#crctable DIV256:ADCj2%:STAj2%:\Add crctable base
 1530LDY#0:\crc=crctable[(crc EORbyte) AND&FF] EOR(crc >> 8)
 1540.crcstore
 1550LDA(j1%),Y:INY:EORcrclocal%,Y:DEY:STAcrclocal%,Y
 1560INY:CPY#4:BNEcrcstore:RTS
 1570]
 1580=X
 1590:
 1600DEFFNasmarm
 1610[OPTX
 1620.crccalc
 1630\R0= length of bytes to mix  R1= current byte offset
 1640\R2= current CRC             R3->mem%
 1650\R4->crctable                R5= scratch
 1660\R9->pointer to ask%
 1670STMFD R13!,{R14}
 1680LDR R0,[R9]:\Assume 1 parameter,ask%
 1690LDR R0,[R0]:\Read ask%
 1700LDR R3,crcdata:\Point to mem%
 1710LDR R4,crclookup
 1720LDR R2,crclocal%
 1730MVN R2,R2
 1740MVN R1,#0
 1750.crcloop
 1760ADD R1,R1,#1:CMP R1,R0:\See if finished yet
 1770BLNEcrcdo:BNEcrcloop
 1780.crcdone
 1790MVN R2,R2
 1800STR R2,crclocal%
 1810LDMFD R13!,{PC}
 1820.crcdo
 1830LDRB R5,[R3,R1]:EOR R5,R2,R5:AND R5,R5,#255
 1840MOV R5,R5,ASL#2:\Find offset in crctable
 1850LDR R5,[R4,R5]:\Add crctable base
 1860MOV R2,R2,LSR#8
 1870EOR R2,R5,R2:\crc=crctable[(crc EORbyte) AND&FF] EOR(crc >> 8)
 1880MOV PC,R14
 1890]
 1900=X
 1910:
 1920DATAJan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec