home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
CLIPPER
/
PKB
/
MAKEZIP.PRG
< prev
next >
Wrap
Text File
|
1993-01-30
|
12KB
|
313 lines
/*┌──────────────────────────────────────────────────────────────────────┐
▌│ │
▌│ Program Name: MAKEZIP.PRG Copyright: Gallagher Computing Corp. │
▌│ Date Created: 11/30/92 Language: Clipper 5.0 │
▌│ Time Created: 15:19:04 Author: Kevin S Gallagher │
▌│ │
▌│ Purpose: Compress source code into a Zip File for any reason. │
▌│ │
▌│ Directives: Many are useful while others are to keep commands on │
▌│ one line, instead of make more than one line of code │
▌│ │
▌│ Libraries: NANFOR.LIB │
▌│ FT_SINKEY() - replaces INKEY() - replacable │
▌│ MENU TO - Enchanced MENU TO command - optional │
▌│ BLINKER - SWAP FUNCTIONS - required │
▌│ │
▌│ │
▌│ ZipTest(): This function is used with Blinkers Swap function to │
▌│ evaluate PKzip v2.00 error return codes. │
▌└──────────────────────────────────────────────────────────────────────┘
▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀ */
#include "makezip.h"
//── Fill this array with files in other directories that are needed for
//── creating application ie. any obj's, program editor config files
static nHandle :=0, Stable := {"C:\BRIEF\STATE.RST"}, aFiles_:={}
function main()
local nAsk, i
IF FILE(IF(PCOUNT()<>0,ZIPFILE,zipname()+".ZIP"))
nAsk:=alert("FRESHEN ZIPFILE?",{" Yes ", " No "})
if nAsk = 1
@0,0 SAY PADR(" FRESHEN "+ZIPFILE,80) color "N/BG"
SwpRunCmd(PKF+IF(PCOUNT()<>0,ZIPFILE,zipname())+" >NUL ", 0,"")
ZipTest( SWPERRLEV() )
@0,0 say PADC("OPERATION COMPLETED SUCCESSFULLY",80) color "W/B"
QUIT
else
@0,0 SAY PADC("OPERATION ABORTED",80) color "W+*/R"
QUIT
endif
ENDIF
//─── Make List file for compressing files
IF ( nHandle:= fcreate(INIFILE,FC_NORMAL)) =-1
ALERT("ERROR CREATING "+INIFILE)
QUIT
ENDIF
aFiles_ :=listext() // get valid extensions
aFiles_ :=TBMenu(aFiles_) // select .ext to compress
AEVAL( aFiles_, cBlock )
//─── Execute next routine only if we have something to do!
IF LEN(Stable) <> 0
AEVAL( Stable, dBlock )
ENDIF
fclose(nHandle)
nAsk:=alert("Edit pklist file",{" Yes ", " No "})
if nAsk = 1
EditText(INIFILE, .T.)
endif
IF FILE(C_FILE)
nAsk := alert("Edit comments for zipfile", {" Yes ", " No "} )
if nAsk = 1
EditText(C_FILE, .T.)
endif
ELSE
nAsk := alert("Create comments for zipfile", {" Yes ", " No "} )
if nAsk = 1
IF ( nHandle:= fcreate(C_FILE,FC_NORMAL)) =-1
ALERT("ERROR CREATING "+C_FILE)
QUIT
ENDIF
nHandle := fcreate(C_FILE,FC_NORMAL)
EditText(C_FILE, .T.)
endif
ENDIF
@0,0 say PADR(" CREATING NEW ZIPFILE",80) color "W+/RB"
SwpRunCmd(PKZ+IF(PCOUNT()<>0,ZIPFILE,zipname())+" >NUL @"+INIFILE, 0,"")
ZipTest( SWPERRLEV() )
if file(C_FILE)
nHandle:= FOPEN(C_FILE,0)
IF FERROR() == 0 .AND. FSEEK(nHandle,0,2) > 3
FCLOSE(nHandle)
ENDIF
SwpRunCmd(PKZ+IF(PCOUNT()<>0,ZIPFILE,zipname())+" -z < "+C_FILE,0,"")
ZipTest( SWPERRLEV() )
endif
#ifdef KILL_UM
IF FERASE(INIFILE) =-1
ALERT("ERROR REMOVING "+INIFILE)
QUIT
ENDIF
IF FILE(C_FILE)
IF FERASE(C_FILE) =-1
ALERT("ERROR REMOVING "+C_FILE)
QUIT
ENDIF
ENDIF
#endif
clearme()
@0,0 say PADR(" OPERATION COMPLETED SUCCESSFULLY",80) color "W+/RB"
return nil
function WriteIt(cFile)
FWriteLine(nHandle,cFile)
return nil
function EditText(cFileName, lEditMode)
local cBuf, lWrite :=.F., oldcolor :=setcolor("w/b"), nCurs :=setcursor(1)
lEditMode :=.T.
cBuf := MEMOREAD(cFileName)
@00,00 say PADR("Edit: "+ cFileName,80) color "w+ /bg"
@MR,00 say PADR(" F2 = Save/Exit F10 = Abort/Exit",80) color "n /bg"
@MR,60 say "Line: Col:" color "gr+/bg"
readinsert(.T.)
cBuf := MEMOEDIT(cBuf,1,0,MR-1,79,lEditMode, "MemoUDF", 250)
if lastkey() = K_F2
lWrite := MEMOWRIT( rtrim(cFileName), cBuf )
endif
readinsert(.F.)
SETCOLOR(oldcolor)
IF lEditMode
setcursor(nCurs)
ENDIF
clearme()
return nil
function MemoUDF( nMode, nLin, nCol )
local nKey, nRval:=0
nKey := LASTKEY()
IF nMode == 0
@MR,66 say nLin picture "9999" color "w+/bg"
@MR,77 say nCol picture "999" color "w+/bg"
ELSEIF nMode == 1 .OR. nMode == 2
do case
case nKey == K_F10
nRval := 27
case nKey == K_F2
nRval := 23
endcase
ENDIF
return (nRval)
FUNCTION zipname
Return STRTRAN(;
IF(MONTH(DATE()) < 10, "0" + STR(MONTH(DATE()),1), STR(MONTH(DATE()),2)) - ;
IF( DAY(DATE()) < 10, "0" + STR(DAY(DATE()),1 ), STR(DAY(DATE()) )) - ;
STR(YEAR(DATE()))," ","")
function ZipTest( nParm )
local nErr :=0
local aArray_:={;
"01 R/O ATTRIBUTES;DIR FULL;NETWORK ERROR", ;
"02 ERROR IN ZIPFILE" , ;
"03 ERROR IN ZIPFILE" , ;
"04 INSUFFICIENT MEMORY" , ;
"05 INSUFFICIENT MEMORY" , ;
"06 INSUFFICIENT MEMORY" , ;
"07 INSUFFICIENT MEMORY" , ;
"08 INSUFFICIENT MEMORY" , ;
"09 INSUFFICIENT MEMORY" , ;
"10 INSUFFICIENT MEMORY" , ;
"11 INSUFFICIENT MEMORY" , ;
"12 NOTHING TO FRESHEN;OR;WRONG COMMAND PARAMETERS USED", ;
"13 FILE DOES NOT EXIST;OR;POSSIBLE DOS I/O ERROR" , ;
"14 INSUFFICIENT DISKSPACE;OR;DISK FULL." , ;
"15 FAILED TO OPEN FILE FOR WRITE ACCESS" , ;
"17 ATTEMPT TO COMPRESS TO MANY FILES;OR;CORRUPT FILE HEADER" , ;
"24 FATAL EMS ERROR" , ;
"25 FATAL EMS ERROR" , ;
"26 DOS 3.0 OR LATER NEEDED TO SPAN DISKS" , ;
"27 NON-REMOVABLE;OR;UNSUPPORTED DEVICE" }
nErr := ASCAN(aArray_,sBlock)
IF nErr == 0
return nil
ENDIF
ALERT( IF( nErr <> 0, SUBS(aArray_[nErr],4),"Unknow Error"),{" QUIT "} )
QUIT
return nil
function clearme
local i,y,oldcur:=setcursor(0)
for i = 0 to maxrow()
scroll(i,0,i,maxcol(),0)
//─── delay rate
inkey(.1)
next
setcursor(oldcur)
return nil
INIT function haha
set(_SET_SCOREBOARD,.F.)
return nil
function TBMenu(aExt_, ;
nBoxType, ;
cBoxColor, ;
cTextColor, ;
cColors, ;
cButtColor, ;
lShadow, ;
nShadColor )
local oldcolor := setcolor(), aTemp_:={}, a_ :={}, b, c, nEle := 1, i, ;
nLen :=0, nKey, oldscrn, oldcursor := setcursor(0), nWhich :=1, nAtt:= 0
aExt_ := if(ValType(aExt_) = "A" , aExt_,{})
nBoxType := if(ValType(nBoxType) = "N" , nBoxType,1)
cBoxColor := if(ValType(cBoxColor) = "C" , cBoxColor, "W+ /B")
cTextColor := if(ValType(cTextColor) = "C" , cTextColor, "W+ /B")
cColors := if(ValType(cColors) = "C" , cColors,"W+/B,W+/RB")
cButtColor := if(ValType(cButtColor) = "C" , cButtColor,"N/W,W+/BG")
lShadow := if(ValType(lShadow) = "L" , lShadow,.T.)
nShadColor := if(ValType(nShadColor) = "N" , nShadColor,5)
if Empty(aExt_)
return nil
endif
oldscrn := savescreen(0,0,MR,MC)
CLS2(113,"ZipMaker ")
@0,0 say PADC("SPACEBAR TO SELECT - ENTER TO CONTINUE",80) color cColors
set(_SET_WRAP,.T.)
setcolor(cTextColor)
nLen := LEN(aExt_)
aTemp_:= ARRAY(nLen)
AFILL( aTemp_,"X")
b:=TBrowseNew(9,34,14,48)
b:colorSpec := cColors
b:colSep := ""
b:goTopBlock := { || nEle:=1 }
b:goBottomBlock := { || nEle:=nLen }
b:SkipBlock := { |n| ArrSkipper( nLen, @nEle, n) }
c:=TBColumnNew(, { || aTemp_[nEle] } )
c:width:=1
b:AddColumn( c )
c:=TBColumnNew(, { || aExt_[nEle] } )
b:colSep := " ══ "
c:width:=8
b:AddColumn( c )
dispbox(6,24,16,53,BOXTYPE[ nBoxType ],cBoxColor)
if lShadow
#ifdef NANNY
FT_SHADOW(6,24,16,53,5) // nShadColor)
#endif
endif
WHILE .T.
STABILIZE b
nEle := if(b:hittop() , 1,nEle)
nEle := if(b:hitbottom(),nLen,nEle)
if b:stabilize()
@7,28 say PADC(LSTRINT(nEle)+"/"+LSTRINT(nLen),22) color cColors
nKey:=FT_SINKEY(0)
endif
DO CASE
CASE nKey == K_UP ; b:up()
CASE nKey == K_DOWN ; b:down()
CASE nKey == K_SPACE
aTemp_[nEle] := IF("X" $ aTemp_[nEle]," ","X")
b:refreshall()
CASE nKey == K_ENTER .OR. nKey == K_ESC .OR. nKey == K_PGDN
@15,31 PROMPT " Custom " COLOR cButtColor
@15,43 PROMPT " All " COLOR cButtColor
MENU TO nWhich
restscreen(0,0,MR,MC,oldscrn)
if nWhich == 1
FOR i = 1 TO nLen
IF(aTemp_[i] == "X", AADD(a_,aExt_[i]), NIL )
NEXT
aTemp_:=ACLONE(a_)
else
aTemp_:=ACLONE(aExt_)
endif
EXIT
ENDCASE
ENDDO
setcolor( oldcolor )
setcursor( oldcursor )
return aTemp_
function ArrSkipper( aLen, curPos, howmany )
local actual
if howmany >=0
if (curPos+howmany) > aLen
actual := alen-curpos
curpos := alen
else
actual := howmany
curpos += howmany
endif
else
if (curPos+howmany) < 1
actual := 1-curPos
curPos := 1
else
actual := howmany
curPos += howmany
endif
endif
return actual