.net 1999 December/netCD65.iso/pc/Software/VirtualA/16bit/vaper16.exe/%MAINDIR%/Lib.ebs

Text File | 1999-10-06 | 18.9 KB | 658 lines

'T:LIBS.EBS (global)
' VA 4.10

'Add file to import queue 16 bit and 32 bit declares
Declare Function AddToDoList16 Pascal Lib "addons.dll" Alias "AddToDoList" (ByVal szService As String, ByVal szFileName As String, ByVal szMailname As String, ByVal iFlags As Long) As Integer
Declare Function AddToDoList32 Pascal Lib "addons32.dll" Alias "AddToDoList" (ByVal szService As String, ByVal szFileName As String, ByVal szMailname As String, ByVal iFlags As Long) As Long

'T:iFlags Global (constants)
Const IM_DELETE = 2048        ' Delete scratchpad file afterwards?

Const fRECEIPT = 1            ' CIS mail receipt
Const fPRIVATE = 2            ' CIS private forum message
Const fNOFORMAT = 4           ' CIS unformatted message

Const BlockSize = 4096

Dim uniquefno As Long
Dim workpath As String
Dim RepFilename As String

'T:MakeFilename (subroutine) (global)
' This takes a directory and filename and returns the full path to the file
' adding a backslash between them if necessary
Function MakeFilename(directory As String, fname As String) As String
    If Right$(directory, 1) <> "\" Then
        MakeFilename = directory & "\" & fname
    Else
        MakeFilename = directory & fname
    End If
End Function

'T:SendCR (subroutine) (global)
'Typical tracker procedure, such as might be used to reply to a "More" prompt
'Sends a carriage return to the service, and removes the prompt from the capture file
Sub SendCR(t As Tracker)
    Print "Matched:"; t.name; ":Sending <cr>"
    Comms.Send "\r"
    CaptureRewind len(t.Match)
    t.reset
End Sub

'T:SendNo (subroutine) (global)
'Typical tracker procedure, such as might be used to reply to a "Y/N" prompt
'Sends an "n" to the service, and removes the prompt from the capture file
Sub SendNo(t As Tracker)
    Print "Matched:"; t.name; ":Sending n<cr>"
    Comms.Send "n\r"
    CaptureRewind len(t.Match)
    t.reset
End Sub

'T:SendYes (subroutine) (global)
'Typical tracker procedure, such as might be used to reply to a "More" prompt
'Sends a "y" to the service, and removes the prompt from the capture file
Sub SendYes(t As Tracker)
    Print "Matched:"; t.name; ":Sending y<cr>"
    Comms.Send "y\r"
    CaptureRewind len(t.Match)
    t.reset
End Sub

'T:ParseString (function) (global)
'Useful library routine to parse a string into individual arguments
'Each call returns the first argument, and removes it from the string
Function ParseString(args As String, delim As String) As String
    Dim p As integer

    p = Instr(args, delim)
    If p Then
        ParseString = Left$(args, p - 1)
        args = Mid$(args, p + Len(delim))
    Else
        ParseString = args
        args = ""
    End If
End Function

'T:DeleteFile (subroutine) (global)
'Routine to delete a file without giving a Basic error
'if the file doesn't exist
Sub DeleteFile(filename As String)
    On Error Resume Next
    Kill filename
    On Error Goto 0
End Sub

'T:WaitForTimed (subroutine) (global)
'Useful routing to wait for a string
'If any existing tracks are hit, any tracker procedures are called,
'but trackers without procedures are ignored and reset
'If the string we wanted doesn't arrive, the Basic error will NOT be trapped
Sub WaitForTimed(s As String, timeout As Integer)
    Dim t As Tracker, t1 As Tracker

    Print "WaitForTimed "; s; timeout
    Trackers.Reset
    Set t = CreateTracker("WaitFor", s, "", True)
    Do
        Set t1 = Wait(timeout)
        t1.reset
    Loop Until t1 = t
    t.delete
End Sub

'T:WaitForWithTimeout (function) (global)
'Useful routine to wait for a string
'If any existing tracks are hit, any tracker procedure are called,
'but trackers without procedures are ignored and reset
'If the string wanted doesn't arrive, then returns False
Function WaitForWithTimeout(s As String, timeout As Integer)
    On Error Goto WaitForWithTimeout_error
    WaitForTimed s, timeout
    WaitForWithTimeout = True
    Print "OK"
    Exit Function
WaitForWithTimeout_error:
    Print "Failed"
    If Err = 1002 Then WaitForWithTimeout = False
    Exit Function
End Function

'T:WaitFor (subroutine) (global) (global)
'Useful routing to wait for a string for 30 seconds
Sub WaitFor(s As String)
    WaitForTimed s, 300
End Sub

'T:WaitForEitherTimed (subroutine) (global)
'Useful routing to wait for 2 different strings
'If any existing tracks are hit, any tracker procedures are called,
'but trackers without procedures are ignored and reset
'If the string we wanted doesn't arrive, the Basic error will NOT be trapped
Function WaitForEitherTimed(s1 As String, s2 As String, timeout As Integer) As String
    Dim t As Tracker, t1 As Tracker, t2 As Tracker

    Print "WaitForEitherTimed "; s1; s2; timeout
    Trackers.Reset
    Set t1 = CreateTracker("WaitFor1", s1)
    Set t2 = CreateTracker("WaitFor2", s2)
    Do
        Set t = Wait(timeout)
        t.reset
    Loop Until t1 = t Or t2 = t
    If t1=t Then
        WaitForEitherTimed = s1
    Else
        WaitForEitherTimed = s2
    End If
    t1.delete
    t2.delete
End Function

'T:WaitWithKick (function) (global)
'Useful routine to wait for a string for 30 seconds, and prod the service
'with another string if it doesn't arrive
Function WaitWithKick(s As String, kick As String)
    Print "WaitWithKick "; s
    On Error Goto WaitWithKick_error
    WaitFor s
    WaitWithKick = True
    Print "OK"
    Exit Function
WaitWithKick_error:
    Print "Failed"
    If Err = 1002 Then Comms.Send kick
    WaitWithKick = False
    Exit Function
End Function

'T:RepeatWaitWithKick (function) (global)
'Repeatedly calls WaitWithKick until we get a result
Function RepeatWaitWithKick(s As String, kick As String, count As Integer)
    Do
        If WaitWithKick(s, kick) Then
            RepeatWaitWithKick = True
            Exit Function
        End If
    count = count - 1
    Loop While count > 0
    RepeatWithKick = False
End Function

'T:SplitPath (subroutine) (global)
'Useful routines to split a path up into its components
Sub SplitPath(fullpath As String, pathonly As String, fileonly As String)
    Dim p As Integer, lastp As Integer

    lastp = 1
    If Len(fullpath) > 2 Then
        If Mid$(fullpath, 2, 1) = ":" Then
            lastp = 3
        End If
    End If
    Do
        p = Instr(lastp, fullpath, "\")
        If p = 0 Then p = Instr(lastp, fullpath, "/")
        if p Then lastp = p + 1
    Loop While p
    pathonly = Left$(fullpath, lastp - 1)
    fileonly = Mid$(fullpath, lastp)
End Sub

'T:FileName$ (function) (global)
Function FileName$(fullpath As String)
    Dim pathonly As String, fileonly As String
    SplitPath fullpath, pathonly, fileonly
    FileName = fileonly
End Function

'T:MakePath (function) (global)
Function MakePath$(directory As String, file As String)
    Dim path As String

    If directory > "" Then
        Select Case Right$(path, 1)
            Case ":", "\", "/"
                path = directory
            Case Else
                path = directory + "\"
        End Select
    End If
    MakePath = path + file
End Function

'T:UniqueFileName (function) (global)
'Generate a unique download filename
Function UniqueFileName$()
    Dim fname As String

    ' Make sure we have a workpath
    If workpath="" Then
        workpath = ReadIni$("Service "+Session.Service, "Work Path", Session.IniFileName)
        If workpath="" Then
            workpath = ReadIni$("Main", "Message Path", Session.IniFileName)
            workpath = MakeFilename(workpath, "temp")
            On Error Resume Next
            MkDir workpath
            WriteIni "Service "+Session.Service, "Work Path", MakeFilename(workpath, ""), Session.IniFileName
        End If
    End If

    On Error Goto UniqueFileName_gotname
    Do
        uniquefno = uniquefno + 1
        fname = MakeFilename(workpath, "msw" + right$(str$(100000+uniquefno), 5) + ".tmp")
        Open fname For Input Access Read Shared As #1
        Close #1
    Loop
UniqueFileName_gotname:
    On Error Goto 0
    UniqueFileName$ = fname
    Exit Function
End Function

'T:ManualTerminal (subroutine) (global)
'Manual Terminal
Sub ManualTerminal
    Dim t As Tracker

    On Error Goto ManualTerminal_error
    LogResult "Manual terminal mode"
    Trackers.delete
    Do
        Print "W";
        Set t = Wait(0)
        Print "R";
    Loop
    Exit Sub
ManualTerminal_error:
    Print
    Print "Terminal Err"; Err; ":"; Erl; ":"; Error$
    If Err = 1002 Or Err = 1003 Or Err = 1004 Then Resume 0
    Print "Terminal - exiting"
    Exit Sub
End Sub

'T:DialService (function) (global)
'Dial the numbers in the ashmount.ini file until connected
Function DialService()
    Print "DialService"
    Redials% = Val(ReadIni$(Session.IniSection, "Retries", Session.IniFileName))
    If Redials% <= 0 Then Redials% = 1
    For i% = 1 to Redials%
        NumberList$ = ReadIni$(Session.IniSection, "Phone", Session.IniFileName)
        If NumberList$ = "" Then Goto DialService_nonumber
        Do
            number$ = ParseString(NumberList, ";")
            If Comms.Dial(number$) Then
DialService_nonumber:
                Terminal.RestartTimer
                If Session.LoginScript <> "" Then
                    Terminal.Status "Logging in - " + Session.LoginScript
                    If Login() Then
                        DialService = True
                        Terminal.Status "Connected to " + Session.Service
                        Exit Function
                    End If
                Else
                    DialService = True
                    Exit Function
                End If
            Else
                If Err = 1006 Then Exit Do
            End If
            Comms.Hangup
        Loop While NumberList$ <> ""
    Next
    DialService = False
End Function

'T:OpenRepFile (subroutine) (internal)
'Opens the LogResult report file
Sub OpenRepFile
    If RepFilename = "" Then StartReportFile
    Open RepFilename For Append Access Read Write Shared As #10
End Sub

'T:LogResult (subroutine) (global)
'Routines to report success or failure of a command
Sub LogResult(result As String)
    Print result
    Terminal.Status result
    OpenRepFile
    Print #10, result
    Close #10
End Sub

'T:ReportSuccess (subroutine) (global)
Sub ReportSuccess(id As String)
    LogResult id + " : Succeeded"
    Open Session.ServicePath + "success.log" For Append Access Read Write Shared As #10
    Print #10, id
    Close #10
End Sub

'T:ReportFailure (subroutine) (global)
Sub ReportFailure(id As String, reason As String)
    LogResult id + " : Failed : " + reason
End Sub

'T:StartReportFile (subroutine) (global)
Sub StartReportFile
    RepFilename = MakeFilename(ReadIni$("Main", "Message Path", Session.IniFileName), Session.Service+".rep")
    Open RepFilename For Append Access Read Write Shared As #10
    Print #10, "!end" ' Just in case something was already there
    Print #10, "!start actions/information Terminal"
    Close #10
End Sub

'T:EndReportFile (subroutine) (global)
Sub EndReportFile
    Dim result As Integer, resultl As Long

    OpenRepFile
    Print #10, "!end"
    Close #10

    ' Don't add to the import queue - since VA32.EXE does this
End Sub

'T:NoSpaces (function) (global)
' Converts "PC Week News" -> "PC_Week_News"
Function NoSpaces(s As String) As String
    Dim tmp As String

    tmp = ""
    For i = 1 To Len(s)
        If Mid(s, i, 1)=" " Then
            tmp = tmp + "_"
        Else
            tmp = tmp + Mid(s, i, 1)
        End If
    Next

    NoSpaces = tmp
End Function

'T:ToSpaces (function) (global)
' Converts "PC_Week_News" -> "PC Week News"
Function ToSpaces(s As String) As String
    Dim tmp As String

    tmp = ""
    For i = 1 To Len(s)
        If Mid(s, i, 1)="_" Then
            tmp = tmp + " "
        Else
            tmp = tmp + Mid(s, i, 1)
        End If
    Next

    ToSpaces = tmp
End Function

'T:Pause (subroutine) (global)
Sub Pause(secs As Integer)
    ' should delay for a bit
    Dim fin As Single

    fin = Timer()+secs
    Do
        DoEvents
    Loop Until Timer()>=fin
End Sub

'T:QueueFile (function) (Global)
'Queue a file for adding to the message base
Function QueueFile(service As String, sfilename As String, queueflags As Long) As Boolean
    Dim fname As String
    Dim result As Integer, resultl As Long

    On Error Goto QueueFile_error
    If Filelen(sfilename) = 0 Then
        Print "File:"; sfilename; " is empty"
        LogResult "File was empty"
        DeleteFile sfilename
        QueueFile = False
        Exit Function
    End If
    Print "Queueing:"; sfilename

    AddToMsgFile sfilename

    If Basic.OS = ebWin32 Then
        resultl = AddToDoList32(service, sfilename, "messages", queueflags)
    Else
        result = AddToDoList16(service, sfilename, "messages", queueflags)
    End If

    ' Run import if it isn't already running
    If ReadIni$("Main", "Stop Import", Session.inifilename) = "NO" then
        Runimport
    End If
    QueueFile = True
    Exit Function
QueueFile_error:
    Print "File:"; sfilename; " "; Error$
    QueueFile = True
    Exit Function
End Function

'T:QueueFileList (function) (Global)
'Queue a file for adding to the message base
Function QueueFileList(service As String, sfilename As String, topic As String) As Boolean
    Dim fname As String
    Dim result As Integer, resultl As Long

    On Error Goto QueueFileList_error
    If Filelen(sfilename) = 0 Then
        Print "File:"; sfilename; " is empty"
        LogResult "File was empty"
        DeleteFile sfilename
        QueueFileList = False
        Exit Function
    End If
    Print "Queueing:"; sfilename

    If Basic.OS = ebWin32 Then
        resultl = AddToDoList32(service, sfilename, topic, IM_DELETE)
    Else
        result = AddToDoList16(service, sfilename, topic, IM_DELETE)
    End If

    ' Run import if it isn't already running
    If ReadIni$("Main", "Stop Import", Session.inifilename) = "NO" then
        Runimport
    End If
    QueueFileList = True
    Exit Function
QueueFileList_error:
    Print "File:"; sfilename; " "; Error$
    QueueFileList = True
    Exit Function
End Function

'T:RunImport (subroutine)
'This routine runs import if it needs to be run
Sub RunImport
    Dim exepath As String, UserName As String
    Dim UserNumber as String, ForgroundImport as String
    Dim SlashUID as Integer, SlashUser as Integer
    Dim VisibleType as Integer
    On Error resume next

    'Workout who the user is so I know what USERNAME.ini file to use
    SlashUser = Instr(Command$, "/USER=")

    'Workout which user logon (/2 /3 etc) this is as well so I know what section to use
    SlashUID=Instr(SlashUser+2, Command$, "/UID=")
    If SlashUID > 0 then
        UserName = Left$(Trim$(Mid$(Command$, SlashUser + 6, SlashUID - SlashUser - 6)),8)
        UserNumber = "/" & Right$(Command$, 1)
    Else
        UserName = Left$(Trim$(Right$(Command$, Len(Command$)-SlashUser - 5)),8)
        UserNumber = ""
    End If

    'Now check the Import To Forground= setting
    ForgroundImport = ReadIni$("Main" & UserNumber, "Import To Foreground", MakeFilename(ReadIni$("Main", "User Path", Session.inifilename), UserName & ".ini"))
    If ForgroundImport = "YES" then
        'Visible with focus
        VisibleType = 1
    Else
        'Minimised whithout focus
        VisibleType = 7
    End If

    ' Run import/import32
    StartImport VisibleType
End Sub

'T:AddToFile (subroutine) (global)
' This takes an input file and it appends it onto another
Sub AddToFile (TargetFileName As String, SourceFileName as String)
    Dim MsgFileNum as Integer, SourceFileNum as Integer
    Dim MsgFileAt as Long, SourceFileAt as Long
    Dim MsgFileLen as Long, SourceFileLen as Long
    Dim TheData as String
    Dim BytesToRead as Long

    On Error Goto AddToFile_error

    If FileExists(TargetFileName) Then
        MsgFileLen = FileLen(TargetFileName)
    Else
        MsgFileLen = 0
    End If
    MsgFileAt = MsgFileLen + 1    'write point
    MsgFileNum = FreeFile()
    Open TargetFileName For Binary Access Read Write Shared As #MsgFileNum

    SourceFileLen = FileLen(SourceFileName)
    BytesToRead = SourceFileLen
    SourceFileNum = FreeFile()
    Open SourceFileName for Binary Access Read Shared as #SourceFileNum
    SourceFileAt = 1        'read point

    TheData = String$(BlockSize, " ")

    ' Operate on blocks of BlockSize at a time
    Do While BytesToRead > BlockSize
        Get #SourceFileNum, SourceFileAt, TheData
        Put #MsgFileNum, MsgFileAt, TheData
        BytesToRead = BytesToRead - BlockSize
        SourceFileAt = SourceFileAt + BlockSize
        MsgFileAt = MsgFileAt + BlockSize
    Loop

    ' Now do the last block of less than BlockSize
    If BytesToRead > 0 then
        TheData = String$(BytesToRead, " ")
        Get #SourceFileNum, SourceFileAt, TheData
        Put #MsgFileNum, MsgFileAt, TheData
    End If

    Close #MsgFileNum
    Close #SourceFileNum
    Exit Sub

AddToFile_error:
    LogResult "Error in AddToFile : " + Str$(Err) + " in line " + Str$(Erl) + ":" + Error$
    Close #SourceFileNum
    Close #MsgFileNum
    Exit Sub
End Sub

'T:AddToMsgFile (subroutine) (global)
' This takes an input file and it appends it onto ~\VAPATH\service\service.msg file for backups
Sub AddToMsgFile (SourceFileName as String)
    Dim MsgFileName As String
    MsgFileName = Session.ServicePath & Left$(Session.Service, 8) & ".msg"
    AddToFile MsgFileName, SourceFileName
End Sub

'T:AddBackslash (subroutine) (global)
' This takes an input string and ensures that the final character is a "\"
Sub AddBackSlash (byRef APath as String)
    If Right$(APath, 1) <> "\" Then APath = APath & "\"
End Sub

'T:LoadAddonLibraries (subroutine) (global)
Sub LoadAddonLibraries
'***************************************************************************
'* Purpose: Loads Addon Script Files                                       *
'*                                                                         *
'* Inputs :                                                                *
'*                                                                         *
'* Returns:                                                                *
'*                                                                         *
'* ----------------------------------------------------------------------- *
'* Revision History                                                        *
'* Date:    Author:   Comments:                                            *
'* ----------------------------------------------------------------------- *
'* 31/01/96 AGB       Created                                              *
'***************************************************************************

Dim sAddonsLine As String
Dim sAddon As String
Dim sScriptFile As String
Dim sMsg As String

    On Error Goto Error_LoadAddonLibraries

    ' Get Addons= line from ashmount.ini
    sAddonsLine = ReadIni$("Main", "Addons", Session.IniFileName)

    ' Process addon line
    Do While Len(sAddonsLine) <> 0

        ' Extract each addon
        sAddon = ParseString(sAddonsLine,",")
        sAddon = Trim(sAddon)

        ' Get ScriptFile= line addon section of ashmount.ini
        sScriptFile = ReadIni$("Addon." & sAddon, "ScriptFile", Session.IniFileName)

        If sScriptFile <> "" Then
            ' Check if file exists
            If FileExists(Session.ServicePath & sScriptFile) = True Then
                LoadScript sScriptFile
            End If
        End If

    Loop

    Exit Sub

Error_LoadAddonLibraries:

    LogResult "Error loading addon libraries"
End Sub

'T:MyDate (function) (Global)
Function MyDate$
    MyDate = FormattedDateTime()
End Function

'T:RecordFileDownload (subroutine) (Global)
Sub RecordFileDownload(topic As String, fname As String)
    Dim fn As String

    fn = Session.ServicePath+"files.ww"
    Open fn For Append Access Read Write Shared As #11
    Print #11, topic+" "+fname
    Close #11
End Sub

'T:FileUrl (function) (Global)
Function FileUrl(fn As String) As String
    If InStr(fn, " ")=0 Then
        FileUrl = "FILE://" + fn
    Else
        FileUrl = "FILE://""" + fn + """"
    End If
End Function