'-----------------------------------'
'WendelSoft Archive 1.0 á           '
'Copyright (c) WendelSoft, 1997-2001'
'10.04.01 - 12.04.01                '
'Wendel Scardua                     '
'-----------------------------------'
DECLARE SUB FillTask (WSA$, arq$)
DECLARE FUNCTION ActualTask$ (n%)
DECLARE SUB Compact (orig$, dest$)
DECLARE SUB Extract (orig$, dest$)
DECLARE SUB WSA.Insert (arq$, WSA$, lv%)
DECLARE FUNCTION WSA.Xtract% (arq$, WSA$)
DECLARE FUNCTION FMatch% (a$, b$)
DECLARE FUNCTION Transform$ (x$)
DECLARE SUB WSA.Xtract0 (arq$, WSA$)
DECLARE SUB WSA.List (WSA$, par$)
'$DYNAMIC
DEFINT A-Z
TYPE wsaFAT
   Arquivo AS STRING * 12
   Tamanho AS LONG
   wsaPOS AS LONG
   Level AS INTEGER
END TYPE
'Seleciona sistema de compacta‡„o:Max deve ser +q 3
CONST Max = 40
CONST Stp = 4
DIM SHARED Table AS wsaFAT
DIM SHARED Task(1 TO 512) AS STRING * 12, nTask AS LONG
CLS
PRINT "WendelSoft Archive 1.0 á"
PRINT "Copyright (c) WendelSoft, 1997-2001"
PRINT
PRINT "Para ajuda digite '?'"
DO
   LINE INPUT ">", cmd$
   cmd$ = LTRIM$(RTRIM$(UCASE$(cmd$)))
   IF cmd$ <> "" THEN
      par1$ = LTRIM$(MID$(cmd$, 2))
      cmd$ = LEFT$(cmd$, 1)
      p = INSTR(par1$, " ")
      IF p THEN
         par2$ = LTRIM$(MID$(par1$, p))
         par1$ = RTRIM$(LEFT$(par1$, p))
         p = INSTR(par2$, " ")
         IF p THEN
            par3$ = LTRIM$(MID$(par2$, p))
            par2$ = RTRIM$(LEFT$(par2$, p))
         ELSE
            par3$ = ""
         END IF
      ELSE
         par2$ = "": par3$ = ""
      END IF
      SELECT CASE cmd$
         CASE "?"
            CLS
            PRINT "Comandos:"
            PRINT " ? "
            PRINT "   Ajuda (lista de comandos)"
            PRINT " N COMPACTO"
            PRINT "   Cria um Arquivo COMPACTO.WSA, de listagem vazia"
            PRINT " I ORIGEM.EXT COMPACTO"
            PRINT "   Insere ORIGEM.EXT em COMPACTO (Nivel inicial: 0,ORIGEM.EXT=sem *,?)"
            PRINT " X ORIGEM.EXT COMPACTO"
            PRINT "   Remove ORIGEM.EXT de COMPACTO (Nivel deve ser 0)"
            PRINT " C ORIGEM.EXT  COMPACTO"
            PRINT "   Compacta arquivo ORIGEM.EXT dentro de COMPACTO.WSA"
            PRINT "   Nivel <- Nivel+1"
            PRINT " E ARQUIVO.EXT COMPACTO"
            PRINT "   Extrai (descompacta) ARQUIVO.EXT dentro de COMPACTO.WSA"
            PRINT "   Nivel <- Nivel-1"
            PRINT " L ARQUIVO [o_que_listar]"
            PRINT "   Lista os arquivos compactados em ARQUIVO.WSA"
            PRINT " Q "
            PRINT "   Sai do WSA"
            PRINT " D "
            PRINT "   Dos Shell"
            PRINT "------------------------------------"
            k$ = INPUT$(1)
            CLS
            PRINT " A COMPACTO"
            PRINT "   Auto-extrai e remove todos os arquivos de COMPACTO.WSA"
            PRINT "------------------------------------"
         CASE "Q"
            PRINT
            PRINT "Saindo do WSA ..."
            PRINT
            EXIT DO
         CASE "N"
            IF par1$ <> "" THEN
               OPEN par1$ + ".WSA" FOR BINARY AS #1
               NumFiles = 0
               PUT #1, 1, NumFiles
               CLOSE #1
            ELSE
               PRINT "Erro: Falta parametro"
            END IF
         CASE "I"
            IF par2$ <> "" THEN
               PRINT "Inserindo "; par1$; " em "; par2$; ".WSA"
               WSA.Insert par1$, par2$, 0
               PRINT "Terminado"
            ELSE
               PRINT "Erro: Falta parametros"
            END IF
         CASE "X"
            IF par2$ <> "" THEN
               FillTask par2$, par1$
               FOR i = 1 TO nTask
                  par1$ = ActualTask$(i)
                  PRINT "Removendo "; par1$; " em "; par2$; ".WSA"
                  WSA.Xtract0 par1$, par2$
                  PRINT "Terminado"
               NEXT
            ELSE
               PRINT "Erro: Falta parametros"
            END IF
         CASE "C"
            IF par2$ <> "" THEN
               FillTask par2$, par1$
               FOR i = 1 TO nTask
                  par1$ = ActualTask$(i)
                  CLS
                  PRINT "Removendo "; par1$; " em "; par2$; ".WSA"
                  ActLevel = WSA.Xtract(par1$, par2$)
                  PRINT "Compactando arquivo externo "; par1$
                  nLevel = VAL(par3$)
                  IF nLevel < 1 THEN nLevel = 1
                  FOR i = 1 TO nLevel
                     Compact par1$, "WSA.$$1"
                     KILL par1$
                     NAME "WSA.$$1" AS par1$
                     ActLevel = ActLevel + 1
                  NEXT
                  PRINT
                  PRINT "Incluindo "; par1$; " em "; par2$; ".WSA"
                  WSA.Insert par1$, par2$, ActLevel
                  PRINT "Nivel atual: "; ActLevel
                  PRINT
                  PRINT "Terminado para "; par1$
               NEXT
            ELSE
               PRINT "Erro: Falta parametros"
            END IF
         CASE "E"
            IF par2$ <> "" THEN
               FillTask par2$, par1$
               FOR i = 1 TO nTask
                  par1$ = ActualTask$(i)
                  CLS
                  PRINT "Removendo "; par1$; " em "; par2$; ".WSA"
                  ActLevel = WSA.Xtract(par1$, par2$)
                  IF ActLevel > 0 THEN
                     PRINT "Descompactando arquivo externo "; par1$
                     IF par3$ = "ALL" THEN nLevel = ActLevel ELSE nLevel = VAL(par3$)
                     IF nLevel < 1 THEN nLevel = 1
                     FOR i = 1 TO nLevel
                        Extract par1$, "WSA.$$1"
                        KILL par1$
                        NAME "WSA.$$1" AS par1$
                        ActLevel = ActLevel - 1
                        IF ActLevel = 0 THEN EXIT FOR
                     NEXT
                  END IF
                  PRINT
                  PRINT "Incluindo "; par1$; " em "; par2$; ".WSA"
                  WSA.Insert par1$, par2$, ActLevel
                  PRINT "Nivel atual: "; ActLevel
                  PRINT
                  PRINT "Terminado para "; par1$
               NEXT
            ELSE
               PRINT "Erro: Falta parametros"
            END IF
         CASE "A"
            IF par1$ <> "" THEN
               par2$ = par1$
               FillTask par2$, "*.*"
               FOR i = 1 TO nTask
                  par1$ = ActualTask$(i)
                  CLS
                  PRINT "Removendo "; par1$; " em "; par2$; ".WSA"
                  ActLevel = WSA.Xtract(par1$, par2$)
                  IF ActLevel > 0 THEN
                     PRINT "Descompactando arquivo externo "; par1$
                     nLevel = ActLevel
                     IF nLevel < 1 THEN nLevel = 1
                     FOR i = 1 TO nLevel
                        Extract par1$, "WSA.$$1"
                        KILL par1$
                        NAME "WSA.$$1" AS par1$
                        ActLevel = ActLevel - 1
                        IF ActLevel = 0 THEN EXIT FOR
                     NEXT
                  END IF
                  PRINT "Terminado para "; par1$
               NEXT
            ELSE
               PRINT "Erro: Falta parametros"
            END IF
         CASE "D"
            PRINT "--------------------------------"
            PRINT "Digite EXIT para retornar ao WSA"
            SHELL
            PRINT "--------------------------------"
         CASE "L"
            IF par1$ <> "" THEN
               WSA.List par1$, par2$
            ELSE
               PRINT "Erro: Falta parametro"
            END IF
      END SELECT
   END IF
LOOP
SYSTEM

REM $STATIC
FUNCTION ActualTask$ (n)
ActualTask$ = RTRIM$(Task(n))
END FUNCTION

SUB Compact (orig$, dest$)
OPEN orig$ FOR BINARY AS #1
OPEN dest$ FOR BINARY AS #2
Byte$ = " "
ct = 0: lng = 0
Buffer$ = "": keylist$ = ""
sk1& = 1
fl1& = LOF(1)
DO UNTIL sk1& > fl1&
   lng = 8192
   IF lng > fl1& - sk1& + 1 THEN lng = fl1& - sk1& + 1
   Buffer$ = SPACE$(lng)
   GET #1, sk1&, Buffer$
   idx = -1: value = 0
   FOR z = 0 TO 255
      k = INSTR(Buffer$, CHR$(z))
      IF k = 0 THEN value = 0: idx = z: cut = lng: EXIT FOR
      IF k > value THEN value = k: idx = z: cut = k - 1
   NEXT
   cidx$ = CHR$(idx)
   lng = cut
   Buffer$ = LEFT$(Buffer$, lng)
   sk1& = sk1& + lng
   LOCATE 6, 1: PRINT USING "Posi‡„o:######## de ########"; sk1& - 1; fl1&;
   IF lng >= Max THEN tb = Max ELSE tb = (lng \ Stp) * Stp
   lng = 0
   ctc = -1
   FOR i = tb TO 3 STEP -Stp
      LOCATE 7, 1: PRINT USING "Bloco Tamanho:##"; i;
      ends = LEN(Buffer$) - i + 1
      j = 1
3           DO UNTIL j > ends
         IF (ends - j) MOD 10 = 0 THEN LOCATE 7, 20: PRINT USING "Cont.Reg.:#####"; ends - j;
         IF ctc = 255 THEN EXIT FOR
         bl$ = MID$(Buffer$, j, i)
         av = INSTR(bl$, cidx$)
         IF av > 0 THEN
            j = j + av + 1: GOTO 3
         ELSEIF j > 1 THEN
            IF MID$(Buffer$, j - 1, 1) = cidx$ THEN j = j + 1: GOTO 3
         END IF
         p = j + i
         IF INSTR(p, Buffer$, bl$) = 0 THEN
            FOR j2 = j + 1 TO ends
               bt$ = MID$(Buffer$, j2, 4)
               IF INSTR(j2 + i, Buffer$, bt$) > 0 THEN EXIT FOR
            NEXT
            j = j2
            GOTO 3
         END IF
         inc = -1
         DO
4           p = INSTR(p, Buffer$, bl$)
            IF p = 0 THEN EXIT DO
            IF MID$(Buffer$, p - 1, 1) = cidx$ THEN p = p + 1: GOTO 4
            IF inc THEN ctc = ctc + 1
            Buffer$ = LEFT$(Buffer$, p - 1) + cidx$ + CHR$(ctc) + MID$(Buffer$, p + i)
            p = p + 2
            ends = ends - i + 2
            IF inc THEN
               keylist$ = keylist$ + CHR$(i) + bl$
               Buffer$ = LEFT$(Buffer$, j - 1) + cidx$ + CHR$(ctc) + MID$(Buffer$, j + i)
               inc = 0
               ends = ends - i + 2
               p = p - i + 2
               j = j + 1
            END IF
         LOOP
         j = j + 1
      LOOP
      IF i > 3 AND i < 7 THEN i = 3 + Stp
   NEXT
   PUT #2, SEEK(2), cidx$
   size = LEN(keylist$)
   PUT #2, SEEK(2), size
   PUT #2, SEEK(2), keylist$
   keylist$ = ""
   size = LEN(Buffer$)
   PUT #2, SEEK(2), size
   PUT #2, SEEK(2), Buffer$
   Buffer$ = ""
   LOCATE 8, 1: PRINT USING "Taxa Parcial:####.##% "; (SEEK(2) - 1) / sk1& * 100
LOOP
taxa# = LOF(2) / fl1& * 100
LOCATE 8, 1: PRINT USING "Taxa :####.##%        "; taxa#;
CLOSE #1, #2
LOCATE 9, 1
IF taxa# >= 100 THEN
   PRINT "Compacta‡„o mal-sucedida: Destino maior que origem"
ELSE
   PRINT "Compacta‡„o bem-sucedida"
END IF
BEEP
END SUB

SUB Extract (orig$, dest$)
DIM keyitem$(0 TO 255)
OPEN orig$ FOR BINARY AS #1
OPEN dest$ FOR BINARY AS #2
Byte$ = " "
cidx$ = " "
DO UNTIL SEEK(1) > LOF(1)
   GET #1, SEEK(1), cidx$
   GET #1, SEEK(1), size
   ctd = -1
   FOR clr = 0 TO 255: keyitem$(clr) = "": NEXT
   DO UNTIL size = 0
      GET #1, SEEK(1), Byte$
      s = ASC(Byte$)
      size = size - s - 1
      ctd = ctd + 1
      keyitem$(ctd) = SPACE$(s)
      GET #1, SEEK(1), keyitem$(ctd)
   LOOP
   GET #1, SEEK(1), size
   Buffer$ = SPACE$(size)
   GET #1, SEEK(1), Buffer$
   nBuffer$ = ""
   DO UNTIL Buffer$ = ""
      p = INSTR(Buffer$, cidx$)
      IF p = 0 THEN EXIT DO
      nBuffer$ = nBuffer$ + LEFT$(Buffer$, p - 1) + keyitem$(ASC(MID$(Buffer$, p + 1, 1)))
      Buffer$ = MID$(Buffer$, p + 2)
   LOOP
   nBuffer$ = nBuffer$ + Buffer$
   Buffer$ = ""
   PUT #2, SEEK(2), nBuffer$
   LOCATE 7, 1: PRINT USING "De:########  Para:########"; SEEK(1) - 1; SEEK(2) - 1;
LOOP
CLOSE #1, #2
BEEP
END SUB

SUB FillTask (WSA$, arq$)
OPEN WSA$ + ".WSA" FOR BINARY AS #1
GET #1, 1, NumFiles
nTask = 0
FOR i = 1 TO NumFiles
   p& = SEEK(1)
   GET #1, p&, Table
   IF FMatch(Table.Arquivo, arq$) THEN nTask = nTask + 1: Task(nTask) = Table.Arquivo
NEXT
CLOSE #1
END SUB

FUNCTION FMatch (a$, b$)
arq1$ = Transform$(a$)
arq2$ = Transform$(b$)
FOR i = 1 TO 12
   x$ = MID$(arq1$, i, 1)
   y$ = MID$(arq2$, i, 1)
   IF x$ <> "?" AND y$ <> "?" AND x$ <> y$ THEN FMatch = 0: EXIT FUNCTION
NEXT
FMatch = -1
END FUNCTION

FUNCTION Transform$ (x$)
p = INSTR(x$, ".")
IF p = 0 THEN
   arq$ = x$: ext$ = "*"
ELSE
   arq$ = LEFT$(x$, p - 1): ext$ = MID$(x$, p + 1)
END IF
p = INSTR(arq$, "*")
IF p THEN arq$ = LEFT$(arq$, p - 1) + STRING$(9 - p, "?")
p = INSTR(ext$, "*")
IF p THEN ext$ = LEFT$(ext$, p - 1) + STRING$(4 - p, "?")
Transform$ = LEFT$(arq$ + SPACE$(8), 8) + "." + LEFT$(ext$ + SPACE$(3), 3)
END FUNCTION

SUB WSA.Insert (arq$, WSA$, lv)
OPEN arq$ FOR BINARY AS #1
NAME WSA$ + ".WSA" AS "WSA.$$0"
OPEN "WSA.$$0" FOR BINARY AS #2
OPEN WSA$ + ".WSA" FOR BINARY AS #3
GET #2, 1, NumFiles
NumFiles = NumFiles + 1
PUT #3, 1, NumFiles
FOR i = 1 TO NumFiles - 1
   GET #2, SEEK(2), Table
   PUT #3, SEEK(3), Table
NEXT
k& = SEEK(3)
PUT #3, k&, Table
DO UNTIL SEEK(2) > LOF(2)
   size = LOF(2) - SEEK(2) + 1
   IF size > 8192 THEN size = 8192
   Buffer$ = SPACE$(size)
   GET #2, SEEK(2), Buffer$
   PUT #3, SEEK(3), Buffer$
LOOP
Table.Arquivo = arq$
Table.Tamanho = LOF(1)
Table.Level = lv
Table.wsaPOS = SEEK(3)
DO UNTIL SEEK(1) > LOF(1)
   size = LOF(1) - SEEK(1) + 1
   IF size > 8192 THEN size = 8192
   Buffer$ = SPACE$(size)
   GET #1, SEEK(1), Buffer$
   PUT #3, SEEK(3), Buffer$
LOOP
PUT #3, k&, Table
CLOSE #1, #2, #3
KILL "WSA.$$0"
KILL arq$
END SUB

SUB WSA.List (WSA$, par$)
PRINT "Listando "; WSA$; ".WSA ..."
OPEN WSA$ + ".WSA" FOR BINARY AS #1
GET #1, 1, NumFiles
IF par$ = "" THEN par$ = "????????.???"
na = 0: sa& = 0: header = -1
FOR i = 1 TO NumFiles
   IF header THEN
      header = 0
      CLS
      PRINT "Arquivo      |Tamanho    |Nivel"
      PRINT "-------------|-----------|-----"
   END IF
   GET #1, SEEK(1), Table
   IF FMatch(Table.Arquivo, par$) THEN
      na = na + 1
      sa& = sa& + Table.Tamanho
      PRINT USING "\          \ |#,###,###  |##"; Table.Arquivo; Table.Tamanho; Table.Level
      IF na MOD 22 = 0 THEN
         PRINT "Pressione alguma tecla..."
         k$ = INPUT$(1)
         header = -1
      END IF
   END IF
NEXT
PRINT USING "Total : #### arquivos    ##,###,### bytes"; na; sa&
CLOSE #1
END SUB

FUNCTION WSA.Xtract (arq$, WSA$)
OPEN arq$ FOR BINARY AS #1
NAME WSA$ + ".WSA" AS "WSA.$$0"
OPEN "WSA.$$0" FOR BINARY AS #2
OPEN WSA$ + ".WSA" FOR BINARY AS #3
GET #2, 1, NumFiles
NumFiles = NumFiles - 1
PUT #3, 1, NumFiles
flag& = 0
FOR i = 1 TO NumFiles + 1
   GET #2, SEEK(2), Table
   IF RTRIM$(Table.Arquivo) = arq$ THEN
      WSA.Xtract = Table.Level
      fsize& = Table.Tamanho
      flag& = fsize& + 22
      pos1& = Table.wsaPOS
   ELSE
      Table.wsaPOS = Table.wsaPOS - flag&
      PUT #3, SEEK(3), Table
   END IF
NEXT
'antes do encontrado
DO UNTIL SEEK(2) > pos1& - 1
   size = pos1& - SEEK(2)
   IF size > 8192 THEN size = 8192
   Buffer$ = SPACE$(size)
   GET #2, SEEK(2), Buffer$
   PUT #3, SEEK(3), Buffer$
LOOP
'o encontrado
DO UNTIL SEEK(2) > pos1& + fsize& - 1
   size = pos1& + fsize& - SEEK(2)
   IF size > 8192 THEN size = 8192
   Buffer$ = SPACE$(size)
   GET #2, SEEK(2), Buffer$
   PUT #1, SEEK(1), Buffer$
LOOP
'apos o encontrado
DO UNTIL SEEK(2) > LOF(2)
   size = LOF(2) - SEEK(2) + 1
   IF size > 8192 THEN size = 8192
   Buffer$ = SPACE$(size)
   GET #2, SEEK(2), Buffer$
   PUT #3, SEEK(3), Buffer$
LOOP
CLOSE #1, #2, #3
KILL "WSA.$$0"
END FUNCTION

SUB WSA.Xtract0 (arq$, WSA$)
OPEN arq$ FOR BINARY AS #1
NAME WSA$ + ".WSA" AS "WSA.$$0"
OPEN "WSA.$$0" FOR BINARY AS #2
OPEN WSA$ + ".WSA" FOR BINARY AS #3
GET #2, 1, NumFiles
NumFiles = NumFiles - 1
PUT #3, 1, NumFiles
flag& = 0
FOR i = 1 TO NumFiles + 1
   GET #2, SEEK(2), Table
   IF RTRIM$(Table.Arquivo) = arq$ THEN
      IF Table.Level > 0 THEN
         PRINT "Erro: Nivel maior que 0"
         CLOSE #1, #2, #3
         KILL arq$
         KILL WSA$ + ".WSA"
         NAME "WSA.$$0" AS WSA$ + ".WSA"
         EXIT SUB
      END IF
      fsize& = Table.Tamanho
      flag& = fsize& + 22
      pos1& = Table.wsaPOS
   ELSE
      Table.wsaPOS = Table.wsaPOS - flag&
      PUT #3, SEEK(3), Table
   END IF
NEXT
'antes do encontrado
DO UNTIL SEEK(2) > pos1& - 1
   size = pos1& - SEEK(2)
   IF size > 8192 THEN size = 8192
   Buffer$ = SPACE$(size)
   GET #2, SEEK(2), Buffer$
   PUT #3, SEEK(3), Buffer$
LOOP
'o encontrado
DO UNTIL SEEK(2) > pos1& + fsize& - 1
   size = pos1& + fsize& - SEEK(2)
   IF size > 8192 THEN size = 8192
   Buffer$ = SPACE$(size)
   GET #2, SEEK(2), Buffer$
   PUT #1, SEEK(1), Buffer$
LOOP
'apos o encontrado
DO UNTIL SEEK(2) > LOF(2)
   size = LOF(2) - SEEK(2) + 1
   IF size > 8192 THEN size = 8192
   Buffer$ = SPACE$(size)
   GET #2, SEEK(2), Buffer$
   PUT #3, SEEK(3), Buffer$
LOOP
CLOSE #1, #2, #3
KILL "WSA.$$0"
END SUB