Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Messages - mdijkens

Pages: [1] 2 3

QB64 Discussion / Re: QB64 Bounty List

« on: April 14, 2022, 03:27:47 am »

1. A good Inkey$ like alternative for $console:only on Win and Linux would give much business value for me
2. Shell with stdin and stdout; preferably with _Nowait (to get some multitasking functionality)

QB64 Discussion / Re: Enhancement Request: Inkey$ like functionality for Linux/Mac in $Console mode

« on: April 06, 2022, 06:44:24 pm »

Thanks,

I don't have any linux experience either; just testing in a VM.
But I need to support it often to support colleagues or customers
I've already tried your approach and a lot (crazy) others...

Would be really cool if there's someone with a linux background who could look into this...

QB64 Discussion / Enhancement Request: Inkey$ like functionality for Linux/Mac in $Console mode

« on: April 06, 2022, 10:41:53 am »

I am really happy with all the functionality in QB64 and the professional grade applications we can build with it!
But one thing I'm really missing is an Inkey$ like function for Linux/Mac in $Console mode.
Things like catching arrow-keys or specific alphanumeric keys would be really helpful.
So far I have tried a lot of things to get something working via screenscraping and external tools but no luck until now.
I assume it is hard and totally different from Windows in the nature of terminal sessions but I really hope that something is possible, even in a limited way....
If any one knows workarounds, I'll be excited too

QB64 Discussion / Re: Fickle Increment variable

« on: April 05, 2022, 02:25:22 pm »

If you don't need the timings and sepate up/down events, the regular Inkey$ works easier.
I always do it like this:

Code: QB64: [Select]

Const K_ESC = 27, K_SPACE = 32, K_ENTER = 13, K_BACKSPACE = 8, K_TAB = 9, K_DEL = 339
Const K_UP = 328, K_LEFT = 331, K_RIGHT = 333, K_DOWN = 336
Const K_HOME = 327, K_END = 335, K_PGUP = 329, K_PGDN = 337
 
Do While k% <> K_ESC
  k% = testKey
  Select Case k%
    Case K_SPACE
      x = 0: y = 0
    Case K_UP
      y = y - 1
    Case K_DOWN
      y = y + 1
    Case K_LEFT
      x = x - 1
    Case K_RIGHT
      x = x + 1
    Case K_HOME
      x = -100
    Case K_END
      x = 100
    Case K_PGUP
      y = y - 10
    Case K_PGDN
      y = y + 10
    Case Else
  End Select
Loop
End
 
 
Function testKey%
  ink$ = Chr$(0) + InKey$
  testKey% = Asc(Right$(ink$, 1)) - 256 * (Len(ink$) = 3)
End Function

I also have a variant with added mouse inputs (testKey <0)

Programs / Multithreaded webserver

« on: March 30, 2022, 11:10:28 am »

For workshops I give, I sometimes need an easy mechanism to share (big) files with the audience or vice-versa on a local network.
I decided it would be a nice challenge to build something myself in QB64.
I've also added multithtreading (single CPU core) so people don't have to wait for eachother when downloading/uploading big files

Comments and advice always welcome ...

Code: QB64: [Select]

Const VERSION = "v22.03.30.4"
' Start with root path of webserver as parameter and optional port e.g. mdserver2 d:\mysite 8088
' Place 'favicon.ico' file (+R+H) in root directory
' Place '.auth' file (+R+H) with authorized hashes in all protected directories
 
DefInt A-Z
Const FALSE = 0, TRUE = Not FALSE
 
Const TIMEOUT = 10
Const MAXURLLEN = 32000
Const BLOCKSIZE = 2 ^ 21
Const MAXFILESIZE = 2 ^ 39
$If WIN Then
  Const SEP0 = "/", SEP = "\"
$Else
  Const SEP0 = "\", SEP = "/"
$End If
 
Type reqType
  thread As Integer '                 thread#
  client As Integer '                 http-client#
  Typ As String '                     GET / POST / PUT
  Path As String '                    Path in Url '/../../'
  File As String '                    File in Url 'file.ext'
  Param As String '                   param=123
  Auth As String '                    Authorization hash
  cLen As _Unsigned _Integer64 '      Centent-Length
  cStart As _Unsigned _Integer64 '    Content start
  cEnd As _Unsigned _Integer64 '      Content end
  cBytes As _Unsigned _Integer64 '    Content bytes
  cMime As String '                   Content mime type
  cBoundary As String '               Content multi-part boundary string
  cFileNameIn As String '             Post filename 'file.ext'
  cFileNameOut As String '            '<SEP>...<SEP>file.ext'
  cFileSize As _Unsigned _Integer64 ' Filesize in bytes
End Type
Dim Shared CRLF As String * 2: CRLF = Chr$(13) + Chr$(10)
Dim Shared As String APPLNAME, SITEPATH, PORT
Dim Shared As Integer HOST
 
$Console:Only
_Dest _Console
 
If init Then
  main
End If
System
 
Function init%
  APPLNAME = appName$: SITEPATH = ".": PORT = "8088"
  For c% = 1 To _CommandCount
    cv~% = Val(Command$(c%))
    If cv~% > 0 Then
      PORT = _Trim$(Str$(cv~%))
    Else
      SITEPATH = replace$(_Trim$(Command$(c%)), SEP0, SEP)
    End If
  Next c%
  If SITEPATH = SEP Or Right$(SITEPATH, 2) = ":\" Then SITEPATH = SITEPATH + "."
  If Right$(SITEPATH, 1) = SEP Then SITEPATH = Left$(SITEPATH, Len(SITEPATH) - 1)
  If SITEPATH = "" Or Not _DirExists(SITEPATH) Then SITEPATH = Left$(APPLNAME, _InStrRev(APPLNAME, SEP$) - 1)
 
  printLog "SERVER: '" + APPLNAME + "'"
  printLog "VERSION: " + VERSION
  printLog "PORT: " + PORT
  If Right$(SITEPATH, 2) = "\." Then
    printLog "SITEPATH: '" + Left$(SITEPATH, Len(SITEPATH) - 2) + SEP + "'"
  Else
    printLog "SITEPATH: '" + SITEPATH + SEP + "'"
  End If
  Dim thread(0 To 9) As Integer
  For t% = 0 To 9: thread(t%) = _FreeTimer: Next t%
  On Timer(thread(0), .01) Thread0
  On Timer(thread(1), .01) Thread1
  On Timer(thread(2), .01) Thread2
  On Timer(thread(3), .01) Thread3
  On Timer(thread(4), .01) Thread4
  On Timer(thread(5), .01) Thread5
  On Timer(thread(6), .01) Thread6
  On Timer(thread(7), .01) Thread7
  On Timer(thread(8), .01) Thread8
  On Timer(thread(9), .01) Thread9
  For t% = 0 To 9: Timer(thread(t%)) On: Next t%
 
  HOST = _OpenHost("TCP/IP:" + PORT)
  init% = (HOST < 0)
End Function
 
Sub main
  Timer On
  Do Until _KeyHit = 27
    _Limit 10
  Loop
  Timer Off
End Sub
 
Sub processRequest (thread%)
  client% = _OpenConnection(HOST)
  If client% < 0 Then
    Dim req As reqType: req.thread = thread%: req.client = client%
    Get req.client, , reqBytes$
    If parseRequest(req, reqBytes$) Then
      log$ = LTrim$(Str$(-req.client)) + ":" + req.Typ + " " + req.Path
      If Not authorized(req) Then
        log$ = log$ + "  Authenticate: "
        If req.Auth <> "" Then log$ = log$ + req.Auth
        res$ = httpHeader$(req, 401, ""): Put req.client, , res$
      ElseIf req.Typ = "POST" Then
        received~&& = handlePost(req, reqBytes$)
        log$ = log$ + req.cFileNameIn + " (" + _Trim$(Str$(req.cFileSize)) + ")"
        If received~&& <> req.cLen Then log$ = log$ + "  ERROR !!!"
        'redirect
        res$ = httpHeader$(req, 301, ""): Put req.client, , res$
      ElseIf req.Typ = "GET" Then
        If req.File <> "" Then 'download file
          sent~&& = handleGetFile(req)
          log$ = log$ + req.File
          If req.Param <> "" Then log$ = log$ + "?" + req.Param
          log$ = log$ + " (" + _Trim$(Str$(sent~&&)) + ")"
          If sent~&& = 0 Then ' redirect
            log$ = log$ + "  ERROR: File not found"
            req.Path = "/": res$ = httpHeader$(req, 404, ""): Put req.client, , res$
          End If
        Else ' render page
          html$ = renderDirectory$(req)
          If html$ <> "" Then
            res$ = httpHeader$(req, 200, html$)
          Else
            log$ = log$ + "  ERROR: Path not found"
            res$ = httpHeader$(req, 404, "")
          End If
          Put req.client, , res$
        End If
      Else
        log$ = "ERROR: NOT ALLOWED !!!"
        'redirect
        res$ = httpHeader$(req, 404, ""): Put req.client, , res$
      End If
      printLog log$
    End If
    Close req.client
  End If
End Sub
 
Function renderDirectory$ (req As reqType)
  If Left$(req.Path, 1) <> "/" Or Right$(req.Path, 1) <> "/" Then Exit Function
  fspec$ = replace$(SITEPATH + req.Path, SEP0, SEP)
  If Not _DirExists(fspec$) Then Exit Function
  px12$ = "style='font-family:" + quoted$("Courier New") + "; font-size:12px;'"
  px14$ = "style='font-family:" + quoted$("Arial") + "; font-size:14px;'"
  px20$ = "style='font-family:" + quoted$("Courier New") + "; font-size:20px;'"
  html$ = "<html><body><form enctype='multipart/form-data' action='.' method='POST'>" + _
          "<input type='file' name='filename' " + px14$ + ">" + _
          "<input type='submit' " + px14$ + "></form><hr>" + _
          "<p " + px20$ + ">"
  If req.Path = "/" Then
    html$ = html$ + "/"
  Else
    Dim p$(1000): parts% = split(req.Path, "/", p$())
    href$ = ""
    For i% = 0 To parts% - 2
      href$ = href$ + p$(i%) + "/"
      html$ = html$ + "<a href='" + href$ + "'>" + p$(i%) + "/</a> "
    Next i%
    html$ = html$ + p$(i%)
  End If
  html$ = html$ + "</p><table " + px12$ + ">"
  tmp$ = APPLNAME + LTrim$(Str$(req.thread)) + ".tmp"
  $If WIN Then
    Shell _Hide "DIR /O:GN " + fspec$ + " >" + tmp$
  $Else
    Shell _Hide "ls -l --group-directories-first " + fspec$ + " >" + tmp$
  $End If
  If _FileExists(tmp$) Then
    ff% = FreeFile
    Open tmp$ For Input As ff%
    tdp$ = "<td style='padding-right: 20px;"
    tda$ = tdp$ + " text-align:right;'>"
    apName$ = Mid$(APPLNAME, _InStrRev(APPLNAME, SEP) + 1)
    Do While Not EOF(ff%)
      Line Input #ff%, l$
      $If WIN Then
        If Val(Left$(l$, 2)) > 0 And Right$(l$, 1) <> "." Then
          dat$ = Left$(l$, 16): sz~&& = Val(replace$(Mid$(l$, 18), ",", "")): f$ = Mid$(l$, 36)
          If InStr(l$, "<DIR>") > 0 And sz~&& = 0 Then
    html$ = html$ + "<tr>" + tdp$ + "'><a href='" + req.Path + f$ + "/'>" + f$ + "</a></td>" + _
    "<td/><td>" + dat$ + "</td></tr>"
          ElseIf Left$(f$, 1) <> "." And Left$(f$, Len(apName$)) <> apName$ Then
    html$ = html$ + "<tr>" + tdp$ + "'><a href='" + req.Path + f$ + "'>" + f$ + "</a></td>" + _
    tda$ + Str$(sz~&&) + "</td><td>" + dat$ + "</td></tr>"
          End If
        End If
      $Else
        If InStr("-d", Left$(l$, 1)) > 0 Then
        sp% = 0: For i% = 1 To 4: sp% = InStr(sp% + 1, l$, " "): Next i%: sp% = sp% + 1
        Do While InStr("0123456789", Mid$(l$, sp%, 1)) = 0: sp% = sp% + 1: Loop
        dp% = InStr(sp% + 1, l$, " ")
        sz~&& = Val(Mid$(l$, sp%, dp% - sp%))
        dat$ = _Trim$(Mid$(l$, dp%, 14))
        f$ = _Trim$(Mid$(l$, dp% + 13))
        If Left$(l$, 1) = "d" And sz~&& = 0 Then
        html$ = html$ + "<tr>" + tdp$ + "'><a href='" + req.Path + f$ + "/'>" + f$ + "</a></td>" + _
        "<td/><td>" + dat$ + "</td></tr>"
        ElseIf Left$(f$, 1) <> "." And Left$(f$, Len(apName$)) <> apName$ Then
        html$ = html$ + "<tr>" + tdp$ + "'><a href='" + req.Path + f$ + "'>" + f$ + "</a></td>" + _
        tda$ + Str$(sz~&&) + "</td><td>" + dat$ + "</td></tr>"
        End If
        End If
      $End If
    Loop
    Close ff%
    Kill tmp$
  End If
  html$ = html$ + "</table></body></html>"
  renderDirectory$ = html$
End Function
 
Function handleGetFile~&& (req As reqType)
  If Left$(req.Path, 1) <> "/" Or Right$(req.Path, 1) <> "/" Or req.File = "" Then Exit Function
  fspec$ = replace$(SITEPATH + req.Path + req.File, SEP0, SEP)
  If Not _FileExists(fspec$) Then Exit Function
  ff% = FreeFile: Open fspec$ For Binary Access Read As ff%
  req.cFileSize = LOF(ff%)
  res$ = httpHeader$(req, 200, "")
  If req.cFileSize <= BLOCKSIZE Then
    Put req.client, , res$
    dat$ = String$(req.cFileSize, 0)
    Get ff%, , dat$
    req.cBytes = Len(dat$)
    Put req.client, , dat$
    _Delay .001 'for other threads
  Else
    blocks& = _Ceil((req.cFileSize / BLOCKSIZE))
    dat$ = String$(BLOCKSIZE, 0)
    Put req.client, , res$
    req.cBytes = 0
    For b& = 1 To blocks& - 1
      Get ff%, , dat$
      req.cBytes = req.cBytes + Len(dat$)
      Put req.client, , dat$
      _Delay .001 'for other threads
    Next b&
    dat$ = String$(req.cFileSize Mod BLOCKSIZE, 0)
    Get ff%, , dat$
    req.cBytes = req.cBytes + Len(dat$)
    Put req.client, , dat$
  End If
  Close ff%
  handleGetFile~&& = req.cBytes
End Function
 
Function handlePost~&& (req As reqType, reqBytes$)
  If _FileExists(req.cFileNameOut) Then Exit Function
  If req.cEnd = 0 Then
    content$ = Mid$(reqBytes$, req.cStart)
    req.cBytes = req.cBytes + Len(content$)
  Else
    content$ = Mid$(reqBytes$, req.cStart, req.cEnd - req.cStart - 4)
    req.cBytes = req.cBytes + Len(content$) + Len(req.cBoundary) + 8
  End If
  ff% = FreeFile: Open req.cFileNameOut For Binary Access Write As ff%
  Put ff%, , content$
  req.cFileSize = Len(content$)
  _Delay .001 'for other threads
  If req.cEnd = 0 Then
    Get req.client, , reqBytes$
    tim! = Timer
    Do While req.cBytes < req.cLen And ((86400 + Timer - tim!) Mod 86400) < TIMEOUT
      If Len(reqBytes$) > 0 Then
        req.cEnd = InStr(reqBytes$, req.cBoundary)
        If req.cEnd = 0 Then
          content$ = reqBytes$
          req.cBytes = req.cBytes + Len(content$)
        Else
          content$ = Left$(reqBytes$, req.cEnd - 5)
          req.cBytes = req.cBytes + Len(content$) + Len(req.cBoundary) + 8
        End If
        Put ff%, , content$
        req.cFileSize = req.cFileSize + Len(content$)
        _Delay .001 'for other threads
        tim! = Timer
      End If
      Get req.client, , reqBytes$
    Loop
  End If
  Close ff%
  handlePost~&& = req.cBytes
End Function
 
Function parseRequest% (req As reqType, reqBytes$)
  'printLog reqBytes$ '@@
  parseRequest = FALSE
  req.Typ = "": req.Path = "": req.Param = "": req.File = "": req.Auth = ""
  req.cLen = 0: req.cStart = 0: req.cEnd = 0: req.cMime = "": req.cBoundary = ""
  req.cFileNameIn = "": req.cFileNameOut = ""
  req.cBytes = 0: req.cFileSize = 0
  If Len(reqBytes$) < 36 Then Exit Function
  If Left$(reqBytes$, 5) = "GET /" Then
    req.Typ = "GET": s% = 5
  ElseIf Left$(reqBytes$, 6) = "POST /" Then
    req.Typ = "POST": s% = 6
  Else
    Exit Function
  End If
  h% = InStr(s%, reqBytes$, " HTTP/1.1" + CRLF): If h% = 0 Or h% > MAXURLLEN Then Exit Function
  url$ = Mid$(reqBytes$, s%, h% - s%)
  For i% = 1 To Len(url$)
    uc$ = Mid$(url$, i%, 1)
    If uc$ = "?" Then param% = TRUE
    If Not param% Then
      If InStr("./_-~ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", uc$) > 0 Then req.Path = req.Path + uc$
    Else
      If InStr("=_-~ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", uc$) > 0 Then req.Param = req.Param + uc$
    End If
  Next i%
  If InStr(req.Path, "..") > 0 Or InStr(req.Path, "/.") > 0 Or InStr(req.Path, "./") > 0 Then Exit Function
  If InStr(req.Path, "//") > 0 Or Left$(req.Path, 1) <> "/" Then Exit Function
  bs% = _InStrRev(req.Path, "/")
  req.File = Mid$(req.Path, bs% + 1)
  req.Path = Left$(req.Path, bs%)
  auth% = InStr(reqBytes$, "Authorization: ")
  If auth% > 0 Then req.Auth = Mid$(reqBytes$, auth% + 15, InStr(auth%, reqBytes$, CRLF) - auth% - 15)
  If req.Typ = "POST" Then
    s% = InStr(h%, reqBytes$, "Content-Length: "): If s% = 0 Or s% > h% + 1000 Then Exit Function
    req.cLen = Val(Mid$(reqBytes$, s% + 16)): If req.cLen < 1 Or req.cLen > MAXFILESIZE Then Exit Function
    h% = InStr(s%, reqBytes$, "Content-Type: "): If h% = 0 Or h% > s% + 1000 Then Exit Function
    s% = InStr(h%, reqBytes$, "; boundary="): If s% = 0 Or s% > h% + 100 Then Exit Function
    h% = InStr(s%, reqBytes$, CRLF): If h% = 0 Or h% > s% + 100 Then Exit Function
    req.cBoundary = Mid$(reqBytes$, s% + 11, h% - s% - 11)
    req.cBytes = InStr(h%, reqBytes$, CRLF + CRLF) + 4: If req.cBytes = 0 Or req.cBytes > h% + 1000 Then Exit Function
    s% = InStr(req.cBytes, reqBytes$, req.cBoundary): If s% = 0 Or s% > h% + 1000 Then Exit Function
    h% = InStr(s%, reqBytes$, "; filename="): If h% = 0 Or h% > s% + 100 Then Exit Function
    s% = InStr(h%, reqBytes$, CRLF): If s% = 0 Or s% > h% + 100 Then Exit Function
    req.cFileNameIn = unquoted$(Mid$(reqBytes$, h% + 11, s% - h% - 11))
    req.cFileNameOut = replace$(SITEPATH + req.Path + req.cFileNameIn, SEP0, SEP)
    h% = InStr(s%, reqBytes$, "Content-Type: "): If h% = 0 Or h% > s% + 10 Then Exit Function
    s% = InStr(h%, reqBytes$, CRLF): If s% = 0 Or s% > h% + 100 Then Exit Function
    req.cMime = Mid$(reqBytes$, h% + 14, s% - h% - 14)
    req.cStart = s% + 4
    req.cBytes = req.cStart - req.cBytes
    req.cEnd = InStr(req.cStart, reqBytes$, req.cBoundary)
  End If
  parseRequest = TRUE
End Function
 
Function authorized% (req As reqType)
  fspec$ = replace$(SITEPATH + req.Path, SEP0, SEP) + ".auth"
  If _FileExists(fspec$) Then
    ff% = FreeFile
    Open fspec$ For Input As ff%
    Do While Not EOF(ff%)
      Line Input #ff%, lin$
      If req.Auth = lin$ Then authorized% = TRUE: Exit Do
    Loop
    Close ff%
  Else
    authorized% = TRUE
  End If
End Function
 
Function httpHeader$ (req As reqType, code%, html$)
  Select Case code%
    Case 200 ' render page & favicon.ico & get file
  res$ ="HTTP/1.1 200 OK" + CRLF + _
  "Server: md" + CRLF + "Connection: close" + CRLF
      If html$ <> "" Then ' render page
        res$ = res$ + "Content-Type: text/html" + CRLF + "Content-Length:" + Str$(Len(html$)) + CRLF + CRLF + html$
      ElseIf req.File = "favicon.ico" Then 'get favicon.ico
  res$ = res$ + "Content-Type: image/png" + CRLF + _
  "Content-Length:" + CRLF + Ltrim$(Str$(req.cFileSize)) + CRLF + CRLF
      ElseIf req.cFileSize > 0 Then 'get file
  res$ = res$ + "Content-Type: application/force-download" + CRLF + _
  "Content-Length:" + CRLF + Ltrim$(Str$(req.cFileSize)) + CRLF + _
  "Content-Transfer-Encoding: binary" + _
  "Content-Disposition: attachment; filename=" + quoted$(req.File) + CRLF + CRLF
      End If
    Case 301 'after post & not allowed
  res$ ="HTTP/1.1 301 Moved Permanently" + CRLF + _
  "Location: " + req.Path + CRLF + _
  "Server: md" + CRLF + "Connection: close" + CRLF + "Content-Type: text/html" + CRLF + CRLF
    Case 401 'authenticate
  res$ ="HTTP/1.1 401 Unauthorized" + CRLF + _
  "WWW-Authenticate: Basic" + CRLF + _
  "Server: md" + CRLF + "Connection: close" + CRLF + CRLF
    Case Else '404
  res$ ="HTTP/1.1 404 Not Found" + CRLF + _
  "Server: md" + CRLF + "Connection: close" + CRLF + CRLF
  End Select
  httpHeader$ = res$
End Function
 
Sub printLog (l$)
  ll$ = Date$ + " " + Time$ + " : " + l$
  ff% = FreeFile: Open APPLNAME + ".log" For Append Access Write As ff%
  Print #ff%, ll$
  Close ff%
  Print ll$
End Sub
 
Function quoted$ (q$)
  quoted$ = Chr$(34) + q$ + Chr$(34)
End Function
 
Function unquoted$ (qq$)
  uq$ = _Trim$(qq$): l& = Len(uq$)
  If l& > 0 Then
    If Asc(Left$(uq$, 1)) = 34 And Asc(Mid$(uq$, l&, 1)) = 34 Then
      unquoted$ = _Trim$(Mid$(uq$, 2, l& - 2))
    Else
      unquoted$ = uq$
    End If
  End If
End Function
 
Function replace$ (ir$, i0$, i1$)
  or$ = ir$
  i0len& = Len(i0$)
  i& = InStr(or$, i0$)
  If i0len& = Len(i1$) Then
    Do While i& > 0
      Mid$(or$, i&, i0len&) = i1$
      i& = InStr(or$, i0$)
    Loop
  Else
    Do While i& > 0
      or$ = Left$(or$, i& - 1) + i1$ + Mid$(or$, i& + Len(i0$))
      i& = InStr(or$, i0$)
    Loop
  End If
  replace$ = or$
End Function
 
Function split& (inString As String, delim As String, outArray() As String)
  Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long
  curpos = 1: arrpos = LBound(outArray): LD = Len(delim)
  dpos = InStr(curpos, inString, delim)
  Do Until dpos = 0
    outArray(arrpos) = Mid$(inString, curpos, dpos - curpos)
    arrpos = arrpos + 1
    If arrpos > UBound(outArray) Then ReDim _Preserve outArray(LBound(outArray) To UBound(outArray) + 1000) As String
    curpos = dpos + LD
    dpos = InStr(curpos, inString, delim)
  Loop
  outArray(arrpos) = Mid$(inString, curpos)
  ReDim _Preserve outArray(LBound(outArray) To arrpos) As String
  split& = arrpos
End Function
 
Function appName$ ()
  $If WIN Then
    Declare Library 'Directory Information using KERNEL32
      Function GetModuleFileNameA (ByVal hModule As Long, lpFileName As String, Byval nSize As Long)
    End Declare
    Static appNam$
    If appNam$ = "" Then
      FileName$ = Space$(512): res = GetModuleFileNameA(0, FileName$, Len(FileName$))
      appNam$ = Left$(FileName$, Len(RTrim$(FileName$)) - 5)
    End If
    appName$ = appNam$
  $Else
    appName$ = Command$(0)
  $End If
End Function
 
Sub Thread0 (): processRequest 0: End Sub
Sub Thread1 (): processRequest 1: End Sub
Sub Thread2 (): processRequest 2: End Sub
Sub Thread3 (): processRequest 3: End Sub
Sub Thread4 (): processRequest 4: End Sub
Sub Thread5 (): processRequest 5: End Sub
Sub Thread6 (): processRequest 6: End Sub
Sub Thread7 (): processRequest 7: End Sub
Sub Thread8 (): processRequest 8: End Sub
Sub Thread9 (): processRequest 9: End Sub
 

edit: cleaned it up a bit

Programs / Re: Control digital, pwm and analog signals from QB64

« on: March 18, 2022, 06:10:51 am »

Ik heb nog wat meer geexperimenteerd met de baudrate en daar valt inderdaad nog winst te behalen.
Met mijn NodeMCU (ESP8266 12E) met CP2102 usb-serial chip kom ik op
115200 kbps ~7000/s
128000 kbps ~8000/s
153600 kbps ~10000/s
230400 kbps ~14000/s
daarboven wordt het onbetrouwbaar

Bijgevoegd een wat nettere/betrouwbare versie van mijn experiment

Programs / Re: Control digital, pwm and analog signals from QB64

« on: March 16, 2022, 11:38:42 am »

Intereseting

The CH340G on some ESP boards is capable of 2Mbit USB Serial speeds, so worth to give it a try too.
Do you just enter a higher baudrate in the OPEN statement or just 115200 ?

QB64 Discussion / Re: Input output methods and hardware opinions

« on: March 16, 2022, 04:48:49 am »

I tried to find better (faster) ways to do this and USB serial (at 115k2) is a lot faster then TCP.
See my topic here https://qb64forum.alephc.xyz/index.php?topic=4727.msg141384#msg141384

Programs / Control digital, pwm and analog signals from QB64

« on: March 16, 2022, 04:45:39 am »

Triggered by a question on the forum from Parkland here https://qb64forum.alephc.xyz/index.php?topic=4723.0, I wanted to see how high a performance (reads/writes per second) I could get by controlling a NodeMCU (ESP8266 12E) from QB64
Attached my program that can get up to 4800 datapoints/sec via USB. It is only limited by the max baudrate of qb64 (115k2).
It can read analog, digital, pwm and write digital, pwm.
add/remove what you need to get maximum performance

QB64 Discussion / Re: Has $Debug been working well for you?

« on: March 14, 2022, 12:12:38 pm »

Functionally yes, but not integrated with the new $Debug functionality.
I would still use $ASSERTS for (debug) logging purposes.

QB64 Discussion / Re: Input output methods and hardware opinions

« on: March 14, 2022, 12:09:31 pm »

A half solutions that works for me is to connect to an ESP8266 via wifi and use the I/O of the ESP8266 via TCP connections from QB64.
This still does not give you real fast I/O but at least a few hundred reads/writes a second is achieveable

QB64 Discussion / Re: How do you convert a nested Do Loop into a recursive subroutine call?

« on: March 14, 2022, 10:50:39 am »

I'm not really seeing any recursion pattern in this example

The first one runs through a 'matrix' b,a which is fine (could also be done with 2 nested for-loops)
The second one runs a=1,c=[0,=>] and pauses at a=1,c=100

recursion is mostly evident when you want to do something with a piece of data/sequence and then do the same processing on the remaining part of the data/sequence

QB64 Discussion / Re: Has $Debug been working well for you?

« on: March 14, 2022, 10:30:52 am »

Just using Watchpoints and the condition can only be a simple one variable condition (which I understand from the nature of compiled code).

Wouldn't it be great if there was also a $DEBUG metacommand to set a programmatic watchpoint in your code only to be executed during $DEBUG ?
e.g. something like:

Code: QB64: [Select]

$Debug If a Mod 7 <> Sqr(b) And C = 0 then $DEBUG_BREAK

or:

Code: QB64: [Select]

$DebugBreak When a Mod 7 <> Sqr(b) And C = 0

This might be doable?

It would also be possible if you can detect in code if running in debug-mode

Code: QB64: [Select]

$If $Debug Then
MyWatchExpr1% = a Mod 7 <> Sqr(b) And C = 0
$EndIf

And then put a normal watchpoint on MyWatchExpr1%

QB64 Discussion / Re: No Sound on Mac

« on: March 14, 2022, 10:04:21 am »

I just found out via a youtube video about installing on Mac that on Big Sur Apple deprecated OpenAL library; so no sound om Mac Big Sur.

Is there any plan/idea how to support sound on Mac again in the (near) future?

Also, I do think this should also be noted on: https://wiki.qb64.org/wiki/Keywords_currently_not_supported_by_QB64#Keywords_Not_Supported_in_Linux_or_MAC_OSX_versions

Programs / Re: A skeleton code for Text Scroller via Drag-and-Drop

« on: March 14, 2022, 06:45:10 am »

For DIR-walking, I use my routine below.
If I need sorting I add a custom QuickSort for the specific column

Code: QB64: [Select]

$VersionInfo:FILEVERSION#=22,02,28,2
$VersionInfo:FileDescription=mdDir
$VersionInfo:CompanyName=dijkens.com
$VersionInfo:ProductName=mdDir
$VersionInfo:InternalName=mdDir
$VersionInfo:OriginalFilename=mdDir
$VersionInfo:LegalCopyright=dijkens.com
$VersionInfo:LegalTrademarks=dijkens.com
$VersionInfo:Comments=dijkens.com
$VersionInfo:Web=www.dijkens.com
 
'$Let DEVTEST = 1
$Console:Only
 
Type parmType
  fspec As String 'fpsec
  subs As Integer 'include subs
  search As Integer 'search terms
  icase As Integer 'ignore case
End Type
Dim Shared parm As parmType
Dim Shared stext(10) As String
Const FALSE = 0, TRUE = Not FALSE
 
init
f& = Dir(parm.fspec)
$If DEVTEST = DEFINED Then
  Sleep
$End If
System
 
'$include: 'DIR.BI'
 
Sub init
  Print "mdDir.exe v"; getVersion$
  getParams
  $If DEVTEST = DEFINED Then
    ChDir "E:\_todo\qb64dev"
  $Else
    ChDir _StartDir$
  $End If
End Sub
 
Sub getParams
  'd:\dev\qb64\*.bas /t console:only /c
  For ccount% = 1 To Val(getCommand$(-1))
    cmd$ = getCommand$(ccount%)
    If InStr("-/", Left$(cmd$, 1)) > 0 Then
      Select Case UCase$(Mid$(cmd$, 2, 1))
        Case "S"
          parm.subs = TRUE
        Case "T"
          stext(0) = "sinit"
        Case "C"
          parm.icase = TRUE
        Case Else
          Print " mdDIR [fspec] [/s] [/t search1 [...] [/c]]"
          Print "    fspec           = [d:][path\][filespec] e.g. 'd:\data\*.txt'"
          Print "   /s               = Include sub-directories"
          Print "   /t search1 [...] = Search content for 'search1' (and '...')"
          Print "   /c               = Ignore case in search"
          $If DEVTEST = DEFINED Then
            Sleep
          $End If
          System
      End Select
    ElseIf stext(0) = "" Then
      parm.fspec = cmd$
    Else
      parm.search = parm.search + 1
      stext$(parm.search) = cmd$
    End If
  Next ccount%
  If parm.fspec = "" Then
    parm.fspec = "*.*"
  End If
End Sub
 
Function Dir& (p$)
  b% = DIR.CheckPath(p$)
  If b% > 0 Then
    ddcount& = 0
    If Mid$(p$, b%) = "\*.*" Then
      Print Left$(p$, b%)
      f& = DIR.GetFiles(p$)
      DIR.SortFiles
      If parm.search = 0 Then PrintDirs
      PrintFiles Left$(p$, b%)
      If DIR.Dcount > 0 Then
        ddcount& = DIR.Dcount
        subdir$ = "|"
        For i& = 1 To ddcount&
          subdir$ = subdir$ + DIR.Dname(i&) + "|"
        Next i&
      End If
    Else
      d& = DIR.GetFiles(Left$(p$, b%) + "*")
      If DIR.Dcount > 0 Then
        DIR.SortFiles
        ddcount& = DIR.Dcount
        subdir$ = "|"
        For i& = 1 To ddcount&
          subdir$ = subdir$ + DIR.Dname(i&) + "|"
        Next i&
      End If
      f& = DIR.GetFiles(p$)
      If DIR.Fcount > 0 Then
        DIR.SortFiles
        Print Left$(p$, b%)
        PrintFiles Left$(p$, b%)
      End If
    End If
    If parm.subs Then
      For i& = 1 To ddcount&
        sp& = 0
        For s& = 1 To i&
          sp& = InStr(sp& + 1, subdir$, "|")
        Next s&
        sd$ = Mid$(subdir$, sp& + 1, InStr(sp& + 1, subdir$, "|") - sp& - 1)
        x& = Dir(Left$(p$, b%) + sd$ + Mid$(p$, b%))
      Next i&
    End If
  Else
    f& = 0
  End If
  Dir& = f&
End Function
 
Sub PrintFiles (path$)
  q$ = Chr$(34)
  For i& = 1 To DIR.Fcount
    If textSearch(path$ + DIR.Fname(i&)) Then
      a = DIR.Fattr(i&)
      Attr$ = Space$(4)
      If (a And &H20) = &H20 Then
        Mid$(Attr$, 1, 1) = "A" ' archive
      End If
      If (a And &H4) = &H4 Then
        Mid$(Attr$, 2, 1) = "S" ' system
      End If
      If (a And &H2) = &H2 Then
        Mid$(Attr$, 3, 1) = "H" ' hidden
      End If
      If (a And &H1) = &H1 Then
        Mid$(Attr$, 4, 1) = "R" ' read-only
      End If
      Print Using "\          \##,###,###,### \  \ \                 \ "; DIR.Fshort(i&); DIR.Fsize(i&); Attr$; DIR.Ftime(i&);
      Print DIR.Fname(i&)
    End If
  Next i&
End Sub
 
Function textSearch (fileName$)
  If parm.search = 0 Then textSearch = TRUE: Exit Function
  If Not _FileExists(fileName$) Then textSearch = TRUE: Exit Function
  Dim content As String, block As String * 4194304 '=64*65536
  Dim bsize As _Unsigned Long, fsize As _Unsigned _Integer64, cpos As _Unsigned _Integer64
  Dim blocks As _Unsigned Long, curblock As _Unsigned Long
  bsize = Len(block)
  ff% = FreeFile: Open fileName$ For Random Access Read As #ff% Len = bsize
  $Checking:Off
  fsize = LOF(ff%): content = Space$(fsize): blocks = .5 + fsize / bsize: cpos = 1
  For curblock = 1 To blocks
    Get #ff%, curblock, block
    Mid$(content, cpos, bsize) = block
    cpos = cpos + bsize
  Next curblock
  Close #ff%
  If parm.icase Then content = LCase$(content)
  For s% = 1 To parm.search
    If InStr(content, LCase$(stext(s%))) = 0 Then Exit For
  Next s%
  content = ""
  $Checking:On
  If s% > parm.search Then
    textSearch = TRUE
  Else
    textSearch = FALSE
  End If
End Function
 
Sub PrintDirs
  For i& = 1 To DIR.Dcount
    a = DIR.Dattr(i&)
    Attr$ = Space$(4)
    If (a And &H20) = &H20 Then
      Mid$(Attr$, 1, 1) = "A" ' archive
    End If
    If (a And &H4) = &H4 Then
      Mid$(Attr$, 2, 1) = "S" ' system
    End If
    If (a And &H2) = &H2 Then
      Mid$(Attr$, 3, 1) = "H" ' hidden
    End If
    If (a And &H1) = &H1 Then
      Mid$(Attr$, 4, 1) = "R" ' read-only
    End If
  PRINT USING "\          \     <DIR>     \  \ \                 \ "; _
  DIR.Dshort(i&); Attr$; DIR.Dtime(i&);
    Print DIR.Dname(i&)
  Next i&
End Sub
 
Function getCommand$ (n%)
  Static cmd$(100), ccount As Integer
  If cmd$(0) = "" Then
    Declare Library
      Function GetCommandLineA%& ()
    End Declare
    Dim m As _MEM, ms As String * 1000
    a%& = GetCommandLineA: m = _Mem(a%&, Len(ms)): ms = _MemGet(m, m.OFFSET, String * 1000)
    ccount = 0: sp0% = 1: sp1% = InStr(ms, " ")
    Do While sp1% > 0
      cmd$(ccount) = _Trim$(Mid$(ms, sp0%, sp1% - sp0%))
      If cmd$(ccount) <> "" Then ccount = ccount + 1
      sp0% = sp1% + 1: sp1% = InStr(sp1% + 1, ms, " ")
    Loop
    cmd$(ccount) = _Trim$(Mid$(ms, sp0%)): If Left$(cmd$(ccount), 1) = Chr$(0) Then ccount = ccount - 1
    _MemFree m
  End If
  If n% < 0 Then
    getCommand$ = _Trim$(Str$(ccount))
  ElseIf n% <= ccount Then
    getCommand$ = cmd$(n%)
  Else
    getCommand$ = ""
  End If
End Function
 
Function getVersion$
  Declare Library 'Directory Information using KERNEL32
    Function GetModuleFileNameA (ByVal hModule As Long, lpFileName As String, Byval nSize As Long)
  End Declare
  Declare Dynamic Library "version"
    Function GetFileVersionInfoA (lptstrFilename As String, Byval dwHandle As Long, Byval dwLen As Long, lpData As String)
  End Declare
  FileName$ = Space$(256): res = GetModuleFileNameA(0, FileName$, Len(FileName$))
  lpData$ = Space$(1024): res = GetFileVersionInfoA(FileName$, 0, Len(lpData$), lpData$)
  offset% = Asc(Mid$(lpData$, 3, 1))
  getVersion$ = LTrim$(Str$(Asc(Mid$(lpData$, offset%-1, 1)))) + "." + _
  LTrim$(Str$(Asc(Mid$(lpData$, offset%-3, 1)))) + "." + _
  LTrim$(Str$(Asc(Mid$(lpData$, offset%+3, 1)))) + "." + _
  LTrim$(Str$(Asc(Mid$(lpData$, offset%+1, 1))))
End Function
 

DIR.BI:

Code: QB64: [Select]

'   ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
'   º      DIR.BI  v1.22 (20200815)     maurits@dijkens.com       º
'   ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¶
'   º                                                             º
'   º ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ º
'   º ³                                                         ³ º
'   º ³ FUNCTION DIR.CheckPath (dfspec$)                        ³ º
'   º ³ FUNCTION DIR.GetFiles& (dfspec$)                        ³ º
'   º ³ SUB DIR.SortFiles ()                                    ³ º
'   º ³ SUB DIR.QSortFiles (leftN AS LONG, rightN AS LONG)      ³ º
'   º ³ SUB DIR.QSortDirs (leftN AS INTEGER, rightN AS INTEGER) ³ º
'   º ³                                                         ³ º
'   º ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ º
'   º                                                             º
'   ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ¼
Rem $DYNAMIC
Const __DIR_MAX_PATH = 260
Const __INVALID_HANDLE_VALUE = -1
 
Const DIR.READONLY = &H1
Const DIR.HIDDEN = &H2
Const DIR.SYSTEM = &H4
Const DIR.DIRECTORY = &H10
Const DIR.ARCHIVE = &H20
Const DIR.NORMAL = &H80
Const DIR.TEMPORARY = &H100
Const DIR.SYMBOLICLINK = &H400
Const DIR.COMPRESSED = &H800
Const DIR.NOTINDEXED = &H2000
Const DIR.ENCRYPTED = &H4000
 
 
Type __DIR_FILETIME_TYPE
  dwLowDateTime As _Unsigned Long
  dwHighDateTime As _Unsigned Long
End Type
 
Type __DIR_SYSTEMTIME_TYPE
  wYear As Integer
  wMonth As Integer
  wDayOfWeek As Integer
  wDay As Integer
  wHour As Integer
  wMinute As Integer
  wSecond As Integer
  wMilliseconds As Integer
End Type
 
Type WIN32_FIND_DATAA
  dwFileAttributes As _Unsigned Long
  ftCreationTime As __DIR_FILETIME_TYPE
  ftLastAccessTime As __DIR_FILETIME_TYPE
  ftLastWriteTime As __DIR_FILETIME_TYPE
  nFileSizeHigh As _Unsigned Long
  nFileSizeLow As _Unsigned Long
  dwReserved0 As _Unsigned Long
  dwReserved1 As _Unsigned Long
  cFileName As String * __Dir_max_path
  cAlternateFileName As String * 14
End Type
 
Declare Dynamic Library "kernel32"
  Function FindFirstFileA~%& (ByVal lpFileName~%&, Byval lpFindFileData~%&)
  Function FindNextFileA& (ByVal hFindFile~%&, Byval lpFindFileData~%&)
  Function FindClose& (ByVal hFindFile~%&)
  Function FileTimeToSystemTime& (lpFileTime As __DIR_FILETIME_TYPE, lpSystemTime As __DIR_SYSTEMTIME_TYPE)
  Function FileTimeToLocalFileTime& (lpFileTime As __DIR_FILETIME_TYPE, lpLocalFileTime As __DIR_FILETIME_TYPE)
End Declare
 
Dim Shared DIR.Fname(1) As String
Dim Shared DIR.Dname(1) As String
Dim Shared DIR.Fcount As Long
Dim Shared DIR.Dcount As Long
Dim Shared DIR.Fsize(1) As _Integer64
Dim Shared DIR.Dtime(1) As String * 19 ' mm-dd-yyyy hh:mm:ss
Dim Shared DIR.Ftime(1) As String * 19 ' mm-dd-yyyy hh:mm:ss
Dim Shared DIR.Dattr(1) As _Unsigned Long
Dim Shared DIR.Fattr(1) As _Unsigned Long
Dim Shared DIR.Dshort(1) As String
Dim Shared DIR.Fshort(1) As String
Dim Shared DIR.Error As Integer
 
DIR.err:
DIR.Error = Err
Resume Next
 
Function DIR.CheckPath% (dfspec$)
  dfspec$ = _Trim$(dfspec$)
  If dfspec$ = "" Or Right$(dfspec$, 1) = ":" Then
    dfspec$ = dfspec$ + ".\*.*"
  End If
  For pend% = Len(dfspec$) To 1 Step -1
    If Mid$(dfspec$, pend%, 1) = "\" Then
      Exit For
    End If
  Next pend%
  If _DirExists(dfspec$) Then
    If pend% = Len(dfspec$) Then
      dfspec$ = dfspec$ + "*.*"
    Else
      dfspec$ = dfspec$ + "\*.*"
      pend% = Len(dfspec$) - 3
    End If
  ElseIf pend% = 0 Then
    dp% = InStr(dfspec$, ":")
    dfspec$ = Left$(dfspec$, dp%) + ".\" + Mid$(dfspec$, dp% + 1)
    pend% = dp% + 2
  End If
  If _DirExists(Left$(dfspec$, pend%)) Then
    DIR.Error = 0
    On Error GoTo DIR.err
    ChDir Left$(dfspec$, pend%)
    On Error GoTo 0
    dspec$ = _CWD$
    ChDir _StartDir$
    If DIR.Error = 0 Then
      If Right$(dspec$, 1) <> "\" Then
        dspec$ = dspec$ + "\"
      End If
      DIR.CheckPath% = Len(dspec$)
      dfspec$ = dspec$ + Mid$(dfspec$, pend% + 1)
    Else
      DIR.CheckPath% = 0
    End If
  Else
    DIR.CheckPath% = 0
  End If
End Function
 
Function DIR.GetFiles& (dfspec$)
  Dim Attribute As _Unsigned Long
  Dim ASCIIZ As String * 260
  Dim finddata As WIN32_FIND_DATAA
  Dim Wfile.Handle As _Unsigned _Offset
  Dim SysTime As __DIR_SYSTEMTIME_TYPE
  Dim LocalTime As __DIR_FILETIME_TYPE
 
  Var$ = dfspec$
  DIR.Dcount = 0
  DIR.Fcount = 0
  ASCIIZ = Var$ + Chr$(0)
  Wfile.Handle = FindFirstFileA(_Offset(ASCIIZ), _Offset(finddata))
  If Wfile.Handle <> __INVALID_HANDLE_VALUE Then
    Do
      Attribute = finddata.dwFileAttributes
      Filename$ = finddata.cFileName
      Filename$ = Left$(Filename$, InStr(Filename$, Chr$(0)) - 1)
      If Filename$ <> "." And Filename$ <> ".." And Filename$ <> "$RECYCLE.BIN" And Filename$ <> "System Volume Information" Then
 
        ' store date/time
        x& = FileTimeToLocalFileTime&(finddata.ftLastWriteTime, LocalTime)
        x& = FileTimeToSystemTime&(LocalTime, SysTime)
        Var$ = Right$("00" + LTrim$(Str$(SysTime.wMonth)), 2) + "-"
        Var$ = Var$ + Right$("00" + LTrim$(Str$(SysTime.wDay)), 2) + "-"
        Var$ = Var$ + LTrim$(Str$(SysTime.wYear)) + " "
        Var$ = Var$ + Right$("00" + LTrim$(Str$(SysTime.wHour)), 2) + ":"
        Var$ = Var$ + Right$("00" + LTrim$(Str$(SysTime.wMinute)), 2) + ":"
        Var$ = Var$ + Right$("00" + LTrim$(Str$(SysTime.wSecond)), 2)
 
        If (Attribute And DIR.DIRECTORY) = DIR.DIRECTORY Then
          DIR.Dcount = DIR.Dcount + 1
          ReDim _Preserve DIR.Dname(DIR.Dcount) As String
          DIR.Dname(DIR.Dcount) = Filename$
 
          ReDim _Preserve DIR.Dtime(DIR.Dcount) As String * 19
          DIR.Dtime(DIR.Dcount) = Var$
 
          ReDim _Preserve DIR.Dattr(DIR.Dcount) As _Unsigned Long
          DIR.Dattr(DIR.Dcount) = Attribute
 
          Filename$ = finddata.cAlternateFileName
          Filename$ = Left$(Filename$, InStr(Filename$, Chr$(0)) - 1)
          ReDim _Preserve DIR.Dshort(DIR.Dcount) As String
          If Filename$ <> "" Then
            DIR.Dshort(DIR.Dcount) = Filename$
          Else
            DIR.Dshort(DIR.Dcount) = UCase$(DIR.Dname(DIR.Dcount))
          End If
        Else
          DIR.Fcount = DIR.Fcount + 1
          ReDim _Preserve DIR.Fname(DIR.Fcount) As String
          DIR.Fname(DIR.Fcount) = Filename$
          ReDim _Preserve DIR.Fsize(DIR.Fcount) As _Integer64
          F&& = finddata.nFileSizeHigh * &H100000000~&& Or finddata.nFileSizeLow
          DIR.Fsize(DIR.Fcount) = F&&
 
          ReDim _Preserve DIR.Ftime(DIR.Fcount) As String * 19
          DIR.Ftime(DIR.Fcount) = Var$
 
          ReDim _Preserve DIR.Fattr(DIR.Fcount) As _Unsigned Long
          DIR.Fattr(DIR.Fcount) = Attribute
 
          Filename$ = finddata.cAlternateFileName
          Filename$ = Left$(Filename$, InStr(Filename$, Chr$(0)) - 1)
          ReDim _Preserve DIR.Fshort(DIR.Fcount) As String
          If Filename$ <> "" Then
            DIR.Fshort(DIR.Fcount) = Filename$
          Else
            DIR.Fshort(DIR.Fcount) = UCase$(DIR.Fname(DIR.Fcount))
          End If
        End If
      End If
    Loop While FindNextFileA(Wfile.Handle, _Offset(finddata))
    x& = FindClose(Wfile.Handle)
    DIR.GetFiles& = DIR.Fcount
  Else
    DIR.GetFiles& = -1
  End If
End Function
 
Sub DIR.SortFiles ()
  DIR.QSortDirs 1, DIR.Dcount
  DIR.QSortFiles 1, DIR.Fcount
End Sub
 
Sub DIR.QSortFiles (leftN As Long, rightN As Long)
  Dim pivot As Long, leftNIdx As Long, rightNIdx As Long
  leftNIdx = leftN
  rightNIdx = rightN
  If (rightN - leftN) > 0 Then
    pivot = (leftN + rightN) / 2
    While (leftNIdx <= pivot) And (rightNIdx >= pivot)
      While (UCase$(DIR.Fname(leftNIdx)) < UCase$(DIR.Fname(pivot))) And (leftNIdx <= pivot)
        leftNIdx = leftNIdx + 1
      Wend
      While (UCase$(DIR.Fname(rightNIdx)) > UCase$(DIR.Fname(pivot))) And (rightNIdx >= pivot)
        rightNIdx = rightNIdx - 1
      Wend
      Swap DIR.Fname(leftNIdx), DIR.Fname(rightNIdx)
      Swap DIR.Fshort(leftNIdx), DIR.Fshort(rightNIdx)
      Swap DIR.Fsize(leftNIdx), DIR.Fsize(rightNIdx)
      Swap DIR.Ftime(leftNIdx), DIR.Ftime(rightNIdx)
      Swap DIR.Fattr(leftNIdx), DIR.Fattr(rightNIdx)
      leftNIdx = leftNIdx + 1
      rightNIdx = rightNIdx - 1
      If (leftNIdx - 1) = pivot Then
        rightNIdx = rightNIdx + 1
        pivot = rightNIdx
      ElseIf (rightNIdx + 1) = pivot Then
        leftNIdx = leftNIdx - 1
        pivot = leftNIdx
      End If
    Wend
    DIR.QSortFiles leftN, pivot - 1
    DIR.QSortFiles pivot + 1, rightN
  End If
End Sub
 
Sub DIR.QSortDirs (leftN As Integer, rightN As Integer)
  Dim pivot As Integer, leftNIdx As Integer, rightNIdx As Integer
  leftNIdx = leftN
  rightNIdx = rightN
  If (rightN - leftN) > 0 Then
    pivot = (leftN + rightN) / 2
    While (leftNIdx <= pivot) And (rightNIdx >= pivot)
      While (UCase$(DIR.Dname(leftNIdx)) < UCase$(DIR.Dname(pivot))) And (leftNIdx <= pivot)
        leftNIdx = leftNIdx + 1
      Wend
      While (UCase$(DIR.Dname(rightNIdx)) > UCase$(DIR.Dname(pivot))) And (rightNIdx >= pivot)
        rightNIdx = rightNIdx - 1
      Wend
      Swap DIR.Dname(leftNIdx), DIR.Dname(rightNIdx)
      Swap DIR.Dshort(leftNIdx), DIR.Dshort(rightNIdx)
      Swap DIR.Dtime(leftNIdx), DIR.Dtime(rightNIdx)
      Swap DIR.Dattr(leftNIdx), DIR.Dattr(rightNIdx)
      leftNIdx = leftNIdx + 1
      rightNIdx = rightNIdx - 1
      If (leftNIdx - 1) = pivot Then
        rightNIdx = rightNIdx + 1
        pivot = rightNIdx
      ElseIf (rightNIdx + 1) = pivot Then
        leftNIdx = leftNIdx - 1
        pivot = leftNIdx
      End If
    Wend
    DIR.QSortDirs leftN, pivot - 1
    DIR.QSortDirs pivot + 1, rightN
  End If
End Sub
 

Pages: [1] 2 3

News:

Show Posts

Messages - mdijkens

QB64 Discussion / Re: QB64 Bounty List

QB64 Discussion / Re: Enhancement Request: Inkey$ like functionality for Linux/Mac in $Console mode

QB64 Discussion / Enhancement Request: Inkey$ like functionality for Linux/Mac in $Console mode

QB64 Discussion / Re: Fickle Increment variable

Programs / Multithreaded webserver

Programs / Re: Control digital, pwm and analog signals from QB64

Programs / Re: Control digital, pwm and analog signals from QB64

QB64 Discussion / Re: Input output methods and hardware opinions

Programs / Control digital, pwm and analog signals from QB64

QB64 Discussion / Re: Has $Debug been working well for you?

QB64 Discussion / Re: Input output methods and hardware opinions

QB64 Discussion / Re: How do you convert a nested Do Loop into a recursive subroutine call?

QB64 Discussion / Re: Has $Debug been working well for you?

QB64 Discussion / Re: No Sound on Mac

Programs / Re: A skeleton code for Text Scroller via Drag-and-Drop