POINT Software Programming/PPROG1.ISO/pascal/cx201/vbcxsub.bas

BASIC Source File | 1994-03-01 | 8.6 KB | 307 lines

'  CXSUB functions.
'  Copyright (c) 1990-1994 Eugene Nelson, Four Lakes Computing.
'
'  This file contains useful subroutines that may be used with Cx.
'  See files CXSUB.DOC and BINIO.DOC for interface information.

Const CXSUB_ERR_OPENS = 1
Const CXSUB_ERR_OPEND = 2
Const CXSUB_ERR_NOMEM = 3
Const CXSUB_ERR_READ = 4
Const CXSUB_ERR_WRITE = 5
Const CXSUB_ERR_CLOSE = 6
Const CXSUB_ERR_INVALID = 7

Function cx_compress_file (dst$, src$, method As Integer, bsize As Long, tsize As Long, continue As Integer, bytes As Long)
    Dim ifile As Integer
    Dim ofile As Integer
    Dim k As Integer
    Dim j As Integer

    ifile = binio_open(src$, BINIO_OPEN_READ)
    If ifile = -1 Then
        cx_compress_file = CXSUB_ERR_OPENS
        Exit Function
    End If

    ofile = binio_open(dst$, BINIO_OPEN_CREATE)
    If ofile = -1 Then
        k = binio_close(ifile)
        cx_compress_file = CXSUB_ERR_OPEND
        Exit Function
    End If

    k = cx_compress_ofile(ofile, ifile, method, bsize, tsize, continue, bytes)

    j = binio_close(ifile)
    j = binio_close(ofile)
    If j <> 0 Then j = CXSUB_ERR_CLOSE

    If k = 0 Then cx_compress_file = j Else cx_compress_file = k
End Function

Function cx_compress_ofile (ofile As Integer, ifile As Integer, method As Integer, bsize As Long, tsize As Long, continue As Integer, bytes As Long)
    ReDim ibuff((bsize + 1) / 2) As Integer
    ReDim obuff((bsize + 1) / 2) As Integer
    ReDim tbuff((tsize + 1) / 2) As Integer
    Dim bsizei As Integer
    Dim tsizei As Integer
    Dim l As Long
    Dim lj As Long
    Dim lk As Long
    Dim k As Integer
    Dim j As Integer
    Dim crc As Integer

    bsizei = ltoi(bsize)
    tsizei = ltoi(tsize)

    While True
        DoEvents
        If Not continue Then
            cx_compress_ofile = 0
            Exit Function
        End If

        lj = binio_read(ifile, ibuff(0), bsize)
        j = ltoi(lj)
        If lj = -1 Then
            cx_compress_ofile = CXSUB_ERR_READ
            Exit Function
        End If

        bytes = bytes + lj

        l = binio_write(ofile, j, CXINTSIZE)
        If l <> CXINTSIZE Then
            cx_compress_ofile = CXSUB_ERR_WRITE
            Exit Function
        End If

        If j = 0 Then
            cx_compress_ofile = 0
            Exit Function
        End If

        k = CX_COMPRESS(method, obuff(0), bsizei, ibuff(0), j, tbuff(0), tsizei)
        lk = itol(k)

        If (lk > lj) Then
            cx_compress_ofile = k
            Exit Function
        End If

        l = binio_write(ofile, k, CXINTSIZE)
        If l <> CXINTSIZE Then
            cx_compress_ofile = CXSUB_ERR_WRITE
            Exit Function
        End If

        If k = j Then
            crc = CX_CRC(ibuff(0), k)
            l = binio_write(ofile, crc, CXINTSIZE)
            If l <> CXINTSIZE Then
                cx_compress_ofile = CXSUB_ERR_WRITE
                Exit Function
            End If

            l = binio_write(ofile, ibuff(0), lk)
            If l <> lk Then
                cx_compress_ofile = CXSUB_ERR_WRITE
                Exit Function
            End If
        Else
            crc = CX_CRC(obuff(0), k)
            l = binio_write(ofile, crc, CXINTSIZE)
            If l <> CXINTSIZE Then
                cx_compress_ofile = CXSUB_ERR_WRITE
                Exit Function
            End If

            l = binio_write(ofile, obuff(0), lk)
            If l <> lk Then
                cx_compress_ofile = CXSUB_ERR_WRITE
                Exit Function
            End If
        End If
    Wend
End Function

Function cx_decompress_file (dst$, src$, continue As Integer, bytes As Long)
    Dim ifile As Integer
    Dim ofile As Integer
    Dim k As Integer

    ifile = binio_open(src$, BINIO_OPEN_READ)
    If ifile = -1 Then
        cx_decompress_file = CXSUB_ERR_OPENS
        Exit Function
    End If

    If dst$ <> "" Then
        ofile = binio_open(dst$, BINIO_OPEN_CREATE)
        If ofile = -1 Then
            k = binio_close(ifile)
            cx_decompress_file = CXSUB_ERR_OPEND
            Exit Function
        End If
    Else
        ofile = -1
    End If

    k = cx_decompress_ofile(ofile, ifile, continue, bytes)

    j = binio_close(ifile)
    If ofile = -1 Then j = 0 Else j = binio_close(ofile)
    If j <> 0 Then j = CXSUB_ERR_CLOSE

    If k = 0 Then cx_decompress_file = j Else cx_decompress_file = k
End Function

Function cx_decompress_ofile (ofile As Integer, ifile As Integer, continue As Integer, bytes As Long)
    Dim bsize As Long
    Dim tsize As Long
    Dim bsizei As Integer
    Dim tsizei As Integer
    Dim l As Long
    Dim lj As Long
    Dim lk As Long
    Dim k As Integer
    Dim j As Integer
    Dim crc As Integer

    bsize = 0
    tsize = CX_D_MINTEMP
    tsizei = ltoi(tsize)
    ReDim tbuff((tsize + 1) / 2) As Integer

    While True
        DoEvents
        If Not continue Then
            cx_decompress_ofile = 0
            Exit Function
        End If

        l = binio_read(ifile, j, CXINTSIZE)
        If l <> CXINTSIZE Then
            cx_decompress_ofile = CXSUB_ERR_READ
            Exit Function
        End If

        If j = 0 Then
            cx_decompress_ofile = 0
            Exit Function
        End If

        lj = itol(j)
        If bsize < lj Then
            bsize = lj
            bsizei = ltoi(bsize)
            ReDim ibuff((bsize + 1) / 2) As Integer
            ReDim obuff((bsize + 1) / 2) As Integer
        End If

        bytes = bytes + lj

        l = binio_read(ifile, k, CXINTSIZE)
        If l <> CXINTSIZE Then
            cx_decompress_ofile = CXSUB_ERR_READ
            Exit Function
        End If
        lk = itol(k)

        l = binio_read(ifile, crc, CXINTSIZE)
        If l <> CXINTSIZE Then
            cx_decompress_ofile = CXSUB_ERR_READ
            Exit Function
        End If

        If (lk > lj) Or (lk > bsize) Or (lj > bsize) Then
            cx_decompress_ofile = CXSUB_ERR_INVALID
            Exit Function
        End If

        l = binio_read(ifile, ibuff(0), lk)
        If l <> lk Then
            cx_decompress_ofile = CXSUB_ERR_READ
            Exit Function
        End If

        If CX_CRC(ibuff(0), k) <> crc Then
            cx_decompress_ofile = CXSUB_ERR_INVALID
            Exit Function
        End If

        If j = k Then
            If ofile <> -1 Then
                l = binio_write(ofile, ibuff(0), lk)
                If l <> lk Then
                    cx_decompress_ofile = CXSUB_ERR_WRITE
                    Exit Function
                End If
            End If
        Else
            k = CX_DECOMPRESS(obuff(0), bsizei, ibuff(0), k, tbuff(0), tsizei)
            lk = itol(k)

            If lk > CX_MAX_BUFFER Then
                cx_decompress_ofile = k
                Exit Function
            End If

            If j <> k Then
                cx_decompress_ofile = CXSUB_ERR_INVALID
                Exit Function
            End If

            If ofile <> -1 Then
                l = binio_write(ofile, obuff(0), lk)
                If l <> lk Then
                    cx_decompress_ofile = CXSUB_ERR_WRITE
                    Exit Function
                End If
            End If
        End If
    Wend
End Function

Function cx_error_message (errnum As Long) As String
    Select Case errnum
        Case CX_ERR_INVALID
            s$ = "data could not be decompressed"
        Case CX_ERR_METHOD
            s$ = "invalid compression method"
        Case CX_ERR_BUFFSIZE
            s$ = "invalid buffer size"
        Case CX_ERR_TEMPSIZE
            s$ = "invalid temp buffer size"
        Case CXSUB_ERR_OPENS
            s$ = "could not open source"
        Case CXSUB_ERR_OPEND
            s$ = "could not open destination"
        Case CXSUB_ERR_NOMEM
            s$ = "insufficient memory"
        Case CXSUB_ERR_READ
            s$ = "could not read from source"
        Case CXSUB_ERR_WRITE
            s$ = "could not write to destination"
        Case CXSUB_ERR_CLOSE
            s$ = "could not close destination"
        Case CXSUB_ERR_INVALID
            s$ = "source file is invalid or corrupt"
        Case Else
            s$ = "unknown"
    End Select

    cx_error_message = s$
End Function

Function itol (i As Integer) As Long
    If i < 0 Then itol = 65536 + i Else itol = i
End Function

Function ltoi (l As Long) As Integer
    If l > 32767 Then ltoi = l - 65536 Else ltoi = l
End Function