Collection of Hack-Phreak Scene Programs/cleanhpvac.zip/cleanhpvac/QM95REAL.ZIP/SCRIPTS.Z/HOST.QSC

Text File | 1995-08-24 | 19KB | 743 lines

'
' Host mode script for QmodemPro for Windows.
'
' Version 2.00
'
' Last updated August 5, 1995.
'

'$include 'hostutil.qsc'

' Constants

const BS  = chr(8)
const LF  = chr(10)
const CR  = chr(13)
const ESC = chr(27)

const PrelogFileNamePart   = "host.pre"
const MenuFileNamePart     = "host.mnu"
const ProtocolFileNamePart = "host.pro"
const LogoffFileNamePart   = "host.off"
const HelpFileNamePart     = "host.hlp"

const UserFileNamePart      = "host.usr"
const MsgHeaderFileNamePart = "host.hdr"
const MsgDetailFileNamePart = "host.msg"

const MaxMsgLines = 99

' Type declarations

dialog SetupDialog 18, 18, 214, 240
  caption "QmodemPro Host Setup"
  groupbox "Mode", 101, 18, 9, 74, 64
  modeopen as radiobutton "Open", 102, 26, 23, 62, 12
  modeclosed as radiobutton "Closed", 103, 26, 38, 62, 12
  modecallback as radiobutton "Callback", 104, 26, 53, 62, 12
  groupbox "Security", 150, 100, 9, 100, 64
  maxtime as edittext 105, 151, 22, 42, 12
  dospass as edittext 106, 151, 39, 42, 12
  shutdownpass as edittext 107, 151, 56, 42, 12
  rtext "Max time", -1, 108, 25, 41, 8
  rtext "DOS pwd", -1, 108, 41, 41, 8
  rtext "Shutdown pwd", -1, 108, 59, 41, 8
  groupbox "File transfers", 160, 18, 80, 182, 85
  dlpath as edittext 108, 22, 104, 169, 12
  ulpath as edittext 109, 22, 130, 169, 12
  ltext "Download path", -1, 24, 95, 62, 8
  ltext "Upload path", -1, 24, 120, 69, 8
  sysopanypath as checkbox "Sysop can download from any path", 110, 25, 148, 165, 12
  groupbox "Modem", 170, 18, 175, 182, 30
  modem as combobox 111, 25, 187, 165, 80
  pushbutton "&Modem...", 200, 15, 215, 50, 14
  defpushbutton "OK", IDOK, 81, 215, 50, 14
  pushbutton "Cancel", IDCANCEL, 150, 215, 50, 14
end dialog

dialog ModemSetupDialog 6, 15, 194, 179
  caption "QmodemPro Host Modem Setup"
  groupbox "", -1, 8, 9, 177, 139
  init as edittext 101, 48, 17, 127, 12
  answer as edittext 102, 48, 33, 47, 12
  busy as edittext 103, 48, 49, 47, 12
  ok as edittext 104, 48, 65, 47, 12
  ring as edittext 105, 129, 33, 45, 12
  ringcount as edittext 106, 148, 49, 27, 12
  rtext "&Init", -1, 16, 19, 28, 8
  rtext "&Answer", -1, 12, 34, 33, 8
  rtext "&Busy", -1, 12, 50, 33, 8
  rtext "&OK msg", -1, 13, 66, 32, 8
  rtext "&Ring", -1, 105, 35, 20, 8
  rtext "Ring &Count", -1, 106, 51, 38, 8
  defpushbutton "OK", IDOK, 77, 156, 50, 14
  pushbutton "Cancel", IDCANCEL, 137, 156, 50, 14
end dialog

type TUser
  Name as string*25
  Password as string*20
  Level as integer
  Phone as string*30
end type

type TMessageHeader
  Sender as string*25
  Receiver as string*25
  Subject as string*75
  DateTime as string*20
  Private as integer
  Received as integer
  Killed as integer
  Lines as integer
  Detailpos as long
end type

' connection variables
dim Local as integer
dim Port as integer
dim ModemResult as string
dim BaudRate as long
dim LogonTime as DateTime
dim LogoffTime as DateTime
dim ForceLogoff as integer

dim Setup as SetupDialog
dim ModemSetup as ModemSetupDialog
dim User as TUser
dim MsgLines(MaxMsgLines) as string

dim PrelogFileName as string
dim MenuFileName as string
dim ProtocolFileName as string
dim LogoffFileName as string
dim HelpFileName as string
dim UserFileName as string
dim MsgHeaderFileName as string
dim MsgDetailFileName as string

'$include 'hostcfg.qsc'

declare sub PackMessages

' Utility routines

function MinutesSince(dt as DateTime)
  dim now as DateTime
  GetCurrentDateTime(now)
  dim days as integer, seconds as integer
  DateTimeDiff(now, dt, days, seconds)
  MinutesSince = (days * 86400 + seconds) / 60
end function

function MinutesUntil(dt as DateTime)
  dim now as DateTime
  GetCurrentDateTime(now)
  dim days as integer, seconds as integer
  DateTimeDiff(now, dt, days, seconds)
  MinutesUntil = (days * 86400 + seconds) / 60
end function

function TimeLeft as integer
  TimeLeft = MinutesUntil(LogoffTime)
end function

function CallerHungUp as integer
  CallerHungUp = (not Local and not Carrier) or ForceLogoff
end function

sub DoChat
  dim s as string, c as string
  send #Port,
  send #Port, "You are now chatting with the sysop"
  send #Port,
  do
    c = inkey
    if c = "F2" then
      exit do
    end if
    if c = "" and not Local then
      c = inkey(Port)
    end if
    select case c
      case BS
        if len(s) > 0 then
          s = left(s, len(s)-1)
          send #Port, BS; " "; BS;
        end if
      case CR
        send #Port,
        s = ""
      case is >= " "
        if len(c) = 1 then
          s = s + c
          send #Port, c;
          if len(s) >= 79 then
            if instr(s, " ") then
              dim i as integer
              i = len(s)
              while mid(s, i, 1) <> " "
                i = i - 1
              wend
              send #Port, string(len(s)-i, BS); string(len(s)-i, " ")
              s = mid(s, i+1, len(s)-i)
              send #Port, s;
            else
              send #Port,
              s = ""
            end if
          end if
        end if
    end select
  loop until CallerHungUp
  send #Port,
  send #Port,
  send #Port, "Returning you to host mode"
  send #Port,
end sub

function YesNo(x as integer) as string
  if x then
    YesNo = "Yes"
  else
    YesNo = "No"
  end if
end function

declare function GetLine(prompt as string = "", maxlen as integer = 0, start as string = "", passchar as string = "") as string
function GetLine(prompt as string, maxlen as integer, start as string, passchar as string) as string
  dim s as string
  dim starttime as DateTime
  dim warned as integer
  GetCurrentDateTime(starttime)
  warned = false
  s = start
  send #Port, prompt; s;
  do
    dim c as string
    c = inkey
    if c = "" and not Local then
      c = inkey(Port)
    end if
    select case c
      case ""
        dim idle as integer
        idle = MinutesSince(starttime)
        if idle >= 4 and not warned then
          send #Port,
          send #Port,
          send #Port, "CAUTION!  You will be logged off if you do not continue in 60 seconds!"
          send #Port,
          send #Port, prompt; s;
          warned = true
        elseif idle >= 5 then
          send #Port,
          send #Port,
          send #Port, "Logged off due to inactivity."
          delay 1
          hangup
          ForceLogoff = True
        end if
      case "F2"
        DoChat
        GetCurrentDateTime(starttime)
        send #Port, prompt; s;
      case BS
        if len(s) > 0 then
          s = left(s, len(s)-1)
          send #Port, BS;" ";BS;
        end if
      case CR
        GetLine = s
        send #Port,
        exit function
      case ESC
        ' esc handling
      case is >= " "
        s = s + c
        if len(passchar) > 0 then
          send #Port, passchar;
        else
          send #Port, c;
        end if
        if maxlen > 0 and len(s) >= maxlen then
          GetLine = s
          exit function
        end if
    end select
  loop until TimeLeft < 0 or CallerHungUp
  GetLine = ""
end function

function DisplayFile(fn as string) as integer
  dim f as integer, count as integer
  DisplayFile = TRUE
  f = freefile
  open fn for input as #f
  count = 0
  do while not eof(f)
    dim s as string
    input #f, s
    send #Port, s
    count = count + 1
    if count >= 24 then
      if OemUpper(GetLine("-Pause- [C]ontinue, [S]top? ", 1)) = "S" then
        exit do
      end if
      send #Port,
      count = 0
    end if
  loop
  close #f
catch err_fileopen
  DisplayFile = FALSE
end function

sub SendModemString(s as string)
  dim i as integer, c as string
  i = 1
  while i <= len(s)
    c = mid(s, i, 1)
    if c = "^" and i+1 <= len(s) then
      i = i + 1
      c = mid(s, i, 1)
      if c = "~" then
        delay 0.5
        goto nextchar
      else
        c = chr(asc(c) and 0x3f)
      end if
    end if
    send c;
nextchar:
    i = i + 1
  wend
end sub

sub InitModem
  hostecho off
  ClosePort
  if Setup.modem < GetModemCount then
    AutoAnswer(GetModemName(Setup.modem))
  else
    dim s as string
    s = "COM"+chr(asc("1")+Setup.modem-GetModemCount)
    if not OpenSerialPort(s) then
      MsgBox("Warning: Could not open serial port "+s)
      exit sub
    end if
    dim result as string
    if carrier then exit sub
    timeout 5
  tryagain:
    delay 1
    SendModemString ModemSetup.init
    do
      receive result
    loop until result = ModemSetup.ok
  end if
catch err_timeout
  goto tryagain
end sub

sub UninitModem
  if Setup.modem < GetModemCount then
    AutoAnswer(FALSE)
  else
    ClosePort
  end if
end sub

function ProcessKeyboard(byval k as string)
  ProcessKeyboard = False
  select case OemUpper(k)
    case "F1"
      if ModemSetup.busy <> "" then
        SendModemString ModemSetup.busy
        delay 1
        flush input
      end if
      Local = True
      Port = 0
      ProcessKeyboard = True
    case "F7"
      PackMessages
    case "F8"
      SetupHost
    case "F9"
      print "Host mode terminated, returning to normal operation."
      UninitModem
      end
  end select
end function

function WaitForCall as integer
  WaitForCall = False
  hostecho off
  if carrier then
    Local = False
    Port = comm
    WaitForCall = True
    exit function
  end if
  if Setup.modem < GetModemCount then
    do
      select case WaitForEvent
        case 1
          if ProcessKeyboard(inkey) then
            WaitForCall = True
            exit function
          end if
        case 2
          BaudRate = 19200
          Local = False
          Port = comm
          WaitForCall = True
          exit function
      end select
    loop
  else
    do
      dim rings as integer
      rings = 0
      dim result as string
      do
        dim c as string
        c = inkey(comm)
        if c = "" then
          c = inkey
          if ProcessKeyboard(c) then
            WaitForCall = True
            exit function
          end if
        elseif c = LF then
          result = ""
        else
          result = result + c
          if len(result) > len(ModemSetup.ring) then
            result = right(result, len(result)-1)
          end if
          if result = ModemSetup.ring then
            rings = rings + 1
          end if
        end if
      loop until rings >= val(ModemSetup.ringcount)
      delay 0.2
      SendModemString ModemSetup.answer
      timeout 60
      do
        receive result
        if left(result, 7) = "CONNECT" then
          ModemResult = result
          BaudRate = val(right(ModemResult, len(ModemResult)-8))
          Local = False
          Port = comm
          WaitForCall = True
          exit function
        end if
      loop until result = "NO CARRIER"
    loop
  end if
catch err_timeout
  WaitForCall = False
end function

function NextField(s as string, delim as string) as string
  dim i as integer
  i = instr(s, delim)
  if i > 0 then
    NextField = left(s, i-1)
    s = right(s, len(s)-i)
  else
    NextField = s
    s = ""
  end if
end function

function LookupUser(byval uname as string, user as TUser) as integer
  dim f as integer, s as string
  LookupUser = False
  f = freefile
  open UserFileName for input as #f
  do while not eof(f)
    input #f, s
    dim i as integer
    i = instr(s, ";")
    if i > 0 then
      s = rtrim(left(s, i-1))
    end if
    if OemUpper(uname)+"," = left(s, len(uname)+1) then
      user.Name = NextField(s, ",")
      user.Password = NextField(s, ",")
      user.Level = val(NextField(s, ","))
      user.Phone = NextField(s, ",")
      close #f
      LookupUser = True
      exit function
    end if
  loop
  close #f
catch err_fileopen
end function

function GetPassword as integer
  GetPassword = True
  if User.Password = "" then
    exit function
  end if
  GetPassword = False
  dim password as string, tries as integer
  do
    password = GetLine("Password? ", 0, "", "*")
    if CallerHungUp then
      exit function
    end if
    if OemUpper(password) = OemUpper(User.Password) then
      send #Port, "Password ok"
      GetPassword = True
      exit function
    end if
    tries = tries + 1
    if tries > 3 then
      send #Port,
      send #Port, "Sorry, access denied"
      send #Port,
      exit function
    else
      send #Port,
      send #Port, "Incorrect password entered"
      send #Port,
    end if
  loop
  GetPassword = True
end function

function CallUserBack as integer
  CallUserBack = False
  if User.Phone = "" then
    send #Port, "Your phone number is not on file."
    send #Port, "(click)"
    exit function
  end if
  send #Port, "Hanging up now, type ATA and press Enter after you get a ring."
  delay 1
  hostecho off
  hangup
  delay 10
  if Setup.modem < GetModemCount then
    dial manual User.Phone
    if not carrier then
      error err_timeout
    end if
  else
    send "ATDT"; User.Phone
    timeout 60
    dim result as string
    do
      receive result
      if left(result, 7) = "CONNECT" then
        ModemResult = result
        BaudRate = val(right(ModemResult, len(ModemResult)-8))
        exit do
      end if
    loop
    timeout off
  end if
  hostecho on
  delay 1
  send #Port, "Welcome "; User.Name
  send #Port,
  if GetPassword then
    CallUserBack = True
  end if
catch err_timeout
  send
end function

function GetCallerInfo as integer
  dim uname as string
  do
    uname = OemUpper(GetLine("Please enter your full name? "))
    if CallerHungUp then
      GetCallerInfo = False
      exit function
    end if
    if LookupUser(uname, User) then
      if not GetPassword then
        GetCallerInfo = False
        exit function
      end if
      if Setup.modecallback and not Local then
        if not CallUserBack then
          GetCallerInfo = False
          exit function
        end if
      end if
      GetCallerInfo = True
      exit function
    elseif Setup.modeopen then
      User.Name = uname
      send #Port,
      send #Port, "Your name ";chr(34);uname;chr(34);" was not found in the user list."
      if OemUpper(left(GetLine("Is it spelled correctly? "), 1)) = "Y" then
        exit do
      end if
      send #Port,
    else
      send #Port,
      send #Port, "Sorry, you are not registered with this system."
      send #Port, "(click)"
      send #Port,
      GetCallerInfo = False
      exit function
    end if
  loop
  send #Port,
  do
    dim password as string
    User.Password = GetLine("Please select a password? ", 0, "", "*")
    password      = GetLine("Type your password again? ", 0, "", "*")
    if OemUpper(password) = OemUpper(User.Password) then exit do
    send #Port,
    send #Port, "The passwords you typed did not match.  Try again."
    send #Port,
  loop
  User.Level = 0
  open UserFileName for append as #1
  print #1, User.Name;",";User.Password;",";User.Level
  close #1
  send #Port, "Welcome new user!"
  GetCallerInfo = True
catch err_fileopen
  send "Fatal error - could not open user database"
  GetCallerInfo = False
end function

'$include 'hostfile.qsc'
'$include 'hostmsg.qsc'
'$include 'hostdos.qsc'

sub HelpScreen
  if DisplayFile(HelpFileName) then
    do
      dim s as string
      send #Port,
      send #Port, "Type the letter of the command you would like more help with,"
      s = OemUpper(GetLine("or press Enter to return to the main menu: "))
      if s = "" or CallerHungUp then exit do
      send #Port,
      if not DisplayFile(ConfigScriptPath+"\host" + left(s, 1) + ".hlp") then
        send #Port, "Sorry, no help is available for that item."
      end if
    loop
  else
    send #Port, "Sorry, no help information is available."
  end if
end sub

' Page sysop

sub PageSysop
  send #Port, "Paging sysop..."
  print "(Sysop: Press F2 to enter chat mode)"
  play "RINGIN"
  send #Port,
  GetLine "Press Enter to continue? "
end sub

sub Shutdown
  if User.Level = 0 or Setup.shutdownpass = "" then
    send #Port, "Sorry, shutdown option not available."
    send #Port,
    exit sub
  end if
  if OemUpper(GetLine("Enter shutdown password: ", 0, "", "*")) <> OemUpper(Setup.shutdownpass) then
    send #Port,
    send #Port, "Wrong password entered."
    send #Port,
    exit sub
  end if
  hangup
  UninitModem
  end
end sub

do
  PrelogFileName    = ConfigScriptPath+"\"+PrelogFileNamePart
  MenuFileName      = ConfigScriptPath+"\"+MenuFileNamePart
  ProtocolFileName  = ConfigScriptPath+"\"+ProtocolFileNamePart
  LogoffFileName    = ConfigScriptPath+"\"+LogoffFileNamePart
  HelpFileName      = ConfigScriptPath+"\"+HelpFileNamePart
  UserFileName      = ConfigScriptPath+"\"+UserFileNamePart
  MsgHeaderFileName = ConfigScriptPath+"\"+MsgHeaderFileNamePart
  MsgDetailFileName = ConfigScriptPath+"\"+MsgDetailFileNamePart
  LoadConfig
  InitModem
  do
    cls
    print "QmodemPro for Windows Host Mode"
    print
    print "Press F1 to log on locally"
    print "Press F7 to pack the messages"
    print "Press F8 to set up the host mode"
    print "Press F9 to quit the host mode"
    print
    print "Modem ready for calls..."
  loop until WaitForCall
  timeout off
  ForceLogoff = False
  print "Call connected at "; BaudRate; " baud"
  hostecho on
  delay 1
  send #Port, "Welcome to the Qmodem for Windows host mode!"
  send #Port,
  send #Port, "Modem result: "; ModemResult
  send #Port, "Connected at "; BaudRate; " bps. ";
  send #Port,
  send #Port,
  DisplayFile PrelogFileName
  GetCurrentDateTime(LogonTime)
  call IncDateTime(LogonTime, LogoffTime, 0, val(Setup.MaxTime)*60)
  if GetCallerInfo then
    do
      send #Port,
      DisplayFile MenuFileName
      dim cmd as string
      cmd = GetLine("("+str(TimeLeft)+" min. left) Command? ")
      send #Port,
      select case OemUpper(cmd)
        case "?"
          HelpScreen
        case "D"
          DownloadFile
        case "E"
          EnterMessage
        case "F"
          ListFiles
        case "G"
          DisplayFile LogoffFileName
          send #Port, "Thanks for calling!"
          exit do
        case "P"
          PageSysop
        case "R"
          ReadMessages
        case "S"
          DosShell
        case "U"
          UploadFile
        case "Z"
          Shutdown
        case else
          send #Port, "Unknown command, try again"
      end select
    loop until TimeLeft < 0 or CallerHungUp
  end if
  hostecho off
  if not Local then
    delay 1
    hangup
    delay 1
  end if
loop