diff --git a/app.ico b/app.ico index c9f535e..c5a1a71 100644 Binary files a/app.ico and b/app.ico differ diff --git a/app.rc b/app.rc index 01036d4..77b9141 100644 --- a/app.rc +++ b/app.rc @@ -10,8 +10,8 @@ FB_PROGRAM_ICON ICON "f:\dev\freebasic\projects\audioplayer-sdlmixer\app.ico" // add version and file info in exe windows only VS_VERSION_INFO VERSIONINFO -FILEVERSION 1, 1, 0, 000 -PRODUCTVERSION 1, 1, 0, 0 +FILEVERSION 1, 2, 0, 000 +PRODUCTVERSION 1, 2, 0, 0 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x9L @@ -29,13 +29,13 @@ BEGIN VALUE "Comments", "needs sdl2 and sdl2 mixer libs" VALUE "CompanyName", "" VALUE "FileDescription", "audioplayer with sdl2 mixer" - VALUE "FileVersion", "1, 1, 0, 000" + VALUE "FileVersion", "1, 2, 0, 000" VALUE "InternalName", "" VALUE "LegalCopyright", "" VALUE "OriginalFilename", "audioplayer" VALUE "PrivateBuild", "" VALUE "ProductName", "audioplayer" - VALUE "ProductVersion", "1, 1, 0, 0" + VALUE "ProductVersion", "1, 2, 0, 0" END END BLOCK "VarFileInfo" diff --git a/audioplayer.bas b/audioplayer.bas index 3d6c350..adc0a39 100644 --- a/audioplayer.bas +++ b/audioplayer.bas @@ -10,6 +10,7 @@ #include once "SDL2/SDL.bi" #include once "SDL2/SDL_mixer.bi" #include once "windows.bi" +#Include once "win/mmsystem.bi" #include once "utilfile.bas" #include once "shuffleplay.bas" #cmdline "app.rc" @@ -18,11 +19,14 @@ Mix_OpenAudio(44100,MIX_DEFAULT_FORMAT,2,4096) dim music as Mix_Music ptr dim filename as string = "test.mp3" +dim fileext as string = "" Dim secondsPosition As Double dim tracklength as double Dim musicstate As boolean -Dim currentvolume as integer = 128 -dim locale as string = "en" +Dim currentvolume as integer +dim sourcevolume as integer = 128 +dim drcvolume as single = 0 +dim drc as string = "true" ' setup parsing pls and m3u dim chkcontenttype as boolean = false @@ -47,7 +51,7 @@ dim inival as string dim inifile as string = exepath + "\conf.ini" dim f as integer if FileExists(inifile) = false then - logentry("error", inifile + "file does not excist") + logentry("error", inifile + " file does not excist") else f = readfromfile(inifile) Do Until EOF(f) @@ -58,7 +62,7 @@ else if inival <> "" then select case inikey case "defaultvolume" - currentvolume = val(inival) + sourcevolume = val(inival) case "locale" locale = inival case "usecons" @@ -67,6 +71,8 @@ else logtype = inival case "playtype" playtype = inival + case "drc" + drc = inival end select end if 'print inikey + " - " + inival @@ -74,14 +80,7 @@ else loop close(f) end if - -' get media -imagefolder = command(1) -if imagefolder = "" then - imagefolder = exepath -end if -maxitems = createlist(imagefolder, filetypes, "music") -filename = listplay(playtype, "music") +drcvolume = sourcevolume ' parse commandline for options overides conf.ini settings select case command(1) @@ -92,20 +91,58 @@ select case command(1) delfile(exepath + "\" + "music" + ".lst") logentry("terminate", "normal termination " + appname) end select + +' get media +imagefolder = command(1) +if imagefolder = "" then + imagefolder = exepath +end if if instr(command(1), ".") <> 0 then - filename = imagefolder + fileext = lcase(mid(command(1), instrrev(command(1), "."))) + if instr(1, filetypes, fileext) = 0 and instr(1, ".m3u, .pls", fileext) = 0 then + print command(1) + " file type not supported" + end + end if + if FileExists(exepath + "\" + command(1)) = false then + if FileExists(imagefolder) then + 'nop + else + print imagefolder + " does not excist or is incorrect" + end + end if + else + imagefolder = exepath + "\" + command(1) + end if +else + if checkpath(imagefolder) = false then + print imagefolder + " does not excist or is incorrect" + end + end if +end if +if instr(command(1), ".m3u") = 0 and instr(command(1), ".pls") = 0 then + maxitems = createlist(imagefolder, filetypes, "music") + filename = listplay(playtype, "music") +end if + +if instr(command(1), ".") <> 0 and instr(command(1), ".m3u") = 0 and instr(command(1), ".pls") = 0 then + filename = imagefolder imagefolder = left(command(1), instrrev(command(1), "\") - 1) chk = createlist(imagefolder, filetypes, "music") end if initsdl: -' init window and render -If (SDL_Init(SDL_INIT_VIDEO) = not NULL) Then - logentry("error", "sdl2 video could not be initlized error: " + *SDL_GetError()) +' init audio +' note normaly init video is used but sdl blocks display timeout via powerplan of the os +' to respond to power plan settings for blank display on windows set hint before sdl init video +' use SDL_SetHint(SDL_HINT_VIDEO_ALLOW_SCREENSAVER, "1") +If (SDL_Init(SDL_INIT_AUDIO) = not NULL) Then + logentry("error", "sdl2 audio could not be initlized error: " + *SDL_GetError()) SDL_Quit() else ' render scale quality: 0 point, 1 linear, 2 anisotropic - SDL_SetHint(SDL_HINT_RENDER_SCALE_QUALITY, "1") + 'SDL_SetHint(SDL_HINT_RENDER_SCALE_QUALITY, "1") + ' note this still blocks the screen blank dictated by os power plan + 'SDL_SetHint(SDL_HINT_VIDEO_ALLOW_SCREENSAVER, "1") End If ' compound seconds to hours, minutes, etc @@ -140,216 +177,22 @@ function compoundtime(m As Long) as string return dummy End function -' code by squall4226 -' see https://www.freebasic.net/forum/viewtopic.php?p=149207&hilit=user+need+TALB+for+album#p149207 -Function getmp3tag(searchtag As String, fn As String) As String - 'so we can avoid having the user need TALB for album, TIT2 for title etc, although they are accepted - Dim As Integer skip, offset' in order to read certain things right - Dim As UInteger sig_to_find, count, fnum, maxcheck = 100000 - dim as UShort tag_length - Dim As UShort unitest, mp3frametest - Dim As String tagdata - - Select Case UCase(searchtag) - Case "HEADER", "ID3" - searchtag = "ID3" & Chr(&h03) - Case "TITLE", "TIT2" - searchtag = "TIT2" - Case "ARTIST", "TPE1" - searchtag = "TPE1" - Case "ALBUM", "TALB" - searchtag = "TALB" - Case "COMMENT", "COMM" - searchtag = "COMM" - Case "COPYRIGHT", "TCOP" - searchtag = "TCOP" - Case "COMPOSER", "TCOM" - searchtag = "TCOM" - Case "BEATS PER MINUTE", "BPM", "TPBM" - searchtag = "TBPM" - Case "PUBLISHER", "TPUB" - searchtag = "TPUB" - Case "URL", "WXXX" - searchtag = "WXXX" - Case "PLAY COUNT" "PCNT" - searchtag = "PCNT" - Case "GENRE", "TCON" - searchtag = "TCON" - Case "ENCODER", "TENC" - searchtag = "TENC" - Case "TRACK", "TRACK NUMBER", "TRCK" - searchtag = "TRCK" - Case "YEAR", "TYER" - searchtag = "TYER" - 'Special, in this case we will return the datasize if present, or "-1" if no art - Case "PICTURE", "APIC" - searchtag = "APIC" - 'Not implemented yet! - Case Else - 'Tag may be invalid, but search anyway, there are MANY tags, and we have error checking - End Select - - fnum = FreeFile - Open fn For Binary Access Read As #fnum - If Lof(fnum) < maxcheck Then maxcheck = Lof(fnum) - For count = 0 to maxcheck Step 1 - Get #fnum, count, sig_to_find - If sig_to_find = Cvi(searchtag) Then - If searchtag = "ID3" & Chr(&h03) Then - Close #fnum - Return "1" 'Because there is no data here, we were just checking for the ID3 header - EndIf - 'test for unicode - Get #fnum, count+11, unitest - If unitest = &hFEFF Then 'unicode string - skip = 4 - offset = 13 - Else 'not unicode string - skip = 0 - offset = 10 - EndIf - - Get #fnum, count +7, tag_length 'XXXXYYYZZ Where XXXX is the TAG, YYY is flags or something, ZZ is size - - If tag_length-skip < 1 Then - Close #fnum - Return "ERROR" 'In case of bad things - EndIf - - Dim As Byte dataget(1 To tag_length-skip) - Get #fnum, count+offset, dataget() - - For i As Integer = 1 To tag_length - skip - if dataget(i) < 4 then dataget(i) = 0 ' remove odd characters - If dataget(i) <> 0 Then tagdata + = Chr(dataget(i)) 'remove null spaces from ASCII data in UNICODE string - Next - End If - If tagdata <> "" then exit For ' stop searching! - Next - Close #fnum - - If Len(tagdata) = 0 Then - 'If the tag was just not found or had no data then "----" - tagdata = "----" - EndIf - - Return tagdata - -End Function - -' attempt to extract and write cover art of mp3 to temp thumb file -Function getmp3cover(filename As String) As boolean - Dim buffer As String - dim chunk as string - dim length as string - dim bend as integer - dim ext as string = "" - dim thumb as string - ' remove old thumb if present - delfile(exepath + "\thumb.jpg") - delfile(exepath + "\thumb.png") - Open filename For Binary Access Read As #1 - If LOF(1) > 0 Then - buffer = String(LOF(1), 0) - Get #1, , buffer - End If - Close #1 - if instr(1, buffer, "APIC") > 0 then - length = mid(buffer, instr(buffer, "APIC") + 4, 4) - ' ghetto check funky first 4 bytes signifying length image - ' not sure how reliable this info is - ' see comment codecaster https://stackoverflow.com/questions/47882569/id3v2-tag-issue-with-apic-in-c-net - if val(asc(length, 1) & asc(length, 2)) = 0 then - bend = (asc(length, 3) shl 8) or asc(length, 4) - else - bend = (asc(length, 1) shl 24 + asc(length, 2) shl 16 + asc(length, 3) shl 8 or asc(length, 4)) - end if - if instr(1, buffer, "JFIF") > 0 then - ' override end jpg if marker FFD9 is present - if instr(buffer, CHR(&hFF, &hD9)) > 0 then - bend = instr(1, mid(buffer, instr(1, buffer, "JFIF")), CHR(&hFF, &hD9)) + 7 - end if - chunk = mid(buffer, instr(buffer, "JFIF") - 6, bend) - ' thumbnail detection - if instr(instr(1, buffer, "JFIF") + 4, buffer, "JFIF") > 0 then - chunk = mid(buffer, instr(10, buffer, CHR(&hFF, &hD8)), instr(instr(buffer, CHR(&hFF, &hD9)) + 1, buffer, CHR(&hFF, &hD9)) - (instr(10, buffer, CHR(&hFF, &hD8)) - 2)) - ' thumbnail in thumbnail edge case ffd8 ffd8 ffd9 ffd9 pattern in jpeg - if instr(chunk, CHR(&hFF, &hD8, &hFF)) > 0 then - chunk = mid(buffer,_ - instr(1,buffer, CHR(&hFF, &hD8)),_ - instr(instr(instr(instr(1,buffer, CHR(&hFF, &hD9)) + 1, buffer, CHR(&hFF, &hD9)) + 1, buffer, CHR(&hFF, &hD9))_ - , buffer, CHR(&hFF, &hD9)) + 2 - instr(buffer, CHR(&hFF, &hD8))) - end if - end if - ext = ".jpg" - end if - ' use ext and exif check to catch false png - if instr(1, buffer, "‰PNG") > 0 and instr(1, buffer, "Exif") = 0 and ext = "" then - ' override end png if tag is present - if instr(1, buffer, "IEND") > 0 then - bend = instr(1, mid(buffer, instr(1, buffer, "‰PNG")), "IEND") + 7 - end if - chunk = mid(buffer, instr(buffer, "‰PNG"), bend) - ext = ".png" - end if - ' funky variant for non jfif and jpegs video encoding? - if (instr(1, buffer, "Lavc58") > 0 or instr(1, buffer, "Exif") > 0) and ext = "" then - ' override end jpg if marker FFD9 is present - if instr(buffer, CHR(&hFF, &hD9)) > 0 then - bend = instr(1, mid(buffer, instr(1, buffer, "Exif")), CHR(&hFF, &hD9)) + 7 - end if - if instr(1, buffer, "Exif") > 0 then - chunk = mid(buffer, instr(buffer, "Exif") - 6, bend) - else - chunk = mid(buffer, instr(buffer, "Lavc58") - 6, bend) - end if - ext = ".jpg" - end if - ' last resort just check on begin and end marker very tricky... - ' see https://stackoverflow.com/questions/4585527/detect-end-of-file-for-jpg-images#4614629 - if instr(buffer, CHR(&hFF, &hD8)) > 0 and ext = ""then - chunk = mid(buffer, instr(1, buffer, CHR(&hFF, &hD8)), instr(1, buffer, CHR(&hFF, &hD9))) - ext = ".jpg" - end if - buffer = "" - Close #1 - ' attempt to write thumbnail to temp file - if ext <> "" then - thumb = exepath + "\thumb" + ext - open thumb for Binary Access Write as #1 - put #1, , chunk - close #1 - else - ' no cover art in mp3 optional use folder.jpg if present as thumb - end if - return true - else - ' no cover art in mp3 optional use folder.jpg if present as thumb - logentry("notice", "no cover art found in: " + filename) - return false - end if -end function - if instr(command(1), ".pls") <> 0 then filename = command(1) Open filename For input As 1 open "music.tmp" for output as 2 + itemnr = 0 Do Until EOF(1) Line Input #1, listitem ' ghetto parsing pls if instr(listitem, "=") > 0 then - 'listitem = mid(listitem, instr(listitem, "=") + 1, len(listitem)) select case true case instr(listitem, "numberofentries") > 0 maxitems = val(mid(listitem, instr(listitem, "=") + 1, len(listitem))) - 'print maxitems case instr(listitem, "file" + str(itemnr)) > 0 - 'print "-file-" + mid(listitem, instr(listitem, "=") + 1, len(listitem)) print #2, mid(listitem, instr(listitem, "=") + 1, len(listitem)) case instr(listitem, "title" + str(itemnr)) > 0 - 'print "-title-" + mid(listitem, instr(listitem, "=") + 1, len(listitem)) case instr(listitem, "length" + str(itemnr)) > 0 - 'print "-length-" + mid(listitem, instr(listitem, "=") + 1, len(listitem)) listduration = listduration + val(mid(listitem, instr(listitem, "=") + 1, len(listitem))) itemnr += 1 case len(listitem) = 0 @@ -374,10 +217,8 @@ if instr(command(1), ".m3u") <> 0 then select case true case instr(listitem, "EXTINF:") > 0 listduration = listduration + val(mid(listitem, instr(listitem, ":") + 1, len(instr(listitem, ","))- 1)) - 'print listduration itemnr += 1 case instr(listitem, ".") > 0 - 'print "-file-" + listitem print #2, listitem case len(listitem) = 0 'nop @@ -392,34 +233,136 @@ end if ' listduration for recursive scan dir if maxitems > 1 and instr(command(1), ".m3u") = 0 and instr(command(1), ".pls") = 0 then - print "scanning folder for audiofiles and creating playlist..." dim tmp as integer + dim cnt as integer = 1 ' count items in list - itemlist = "music.tmp" + itemlist = exepath + "\music.tmp" tmp = readfromfile(itemlist) + cls Do Until EOF(tmp) + Locate 1, 1 + print "scanning folder for audiofiles and creating playlist..." Line Input #tmp, listitem music = Mix_LoadMUS(listitem) tracklength = Mix_MusicDuration(music) itemnr += 1 listduration = listduration + tracklength + print cnt + cnt += 1 Mix_FreeMusic(music) Loop close(tmp) end if -' used for ascii interface -Dim currentLine As Integer = CsrLin +' set os fader volume app channel +function setvolumeosmixer(volume as ulong) as boolean + + Dim hMixer As HMIXER + Dim mxlc As MIXERLINECONTROLS + Dim mxcd As MIXERCONTROLDETAILS + Dim mxcd_vol As MIXERCONTROLDETAILS_UNSIGNED + Dim mxl As MIXERLINE + Dim mxlc_vol As MIXERCONTROL + + ' Open the mixer + mixerOpen(@hMixer, 0, 0, 0, 0) + + ' get volume control for app channel + mxlc.cbStruct = SizeOf(MIXERLINECONTROLS) + mxlc.dwControlType = MIXERCONTROL_CONTROLTYPE_VOLUME + mxlc.cControls = 1 + mxlc.cbmxctrl = SizeOf(MIXERCONTROL) + mxlc.pamxctrl = @mxlc_vol + mixerGetLineControls(hMixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE) + + ' get fader volume app channel + mxcd.cbStruct = SizeOf(MIXERCONTROLDETAILS) + mxcd.dwControlID = mxlc_vol.dwControlID + mxcd.cChannels = 1 + mxcd.cMultipleItems = 0 + mxcd.cbDetails = SizeOf(MIXERCONTROLDETAILS_UNSIGNED) + mxcd.paDetails = @mxcd_vol + mixerGetControlDetails(hMixer, @mxcd, MIXER_GETCONTROLDETAILSF_VALUE) + + ' set fader volume app channel + mxcd_vol.dwValue = volume + mxcd.hwndOwner = 0 + mixerSetControlDetails(hMixer, @mxcd, MIXER_SETCONTROLDETAILSF_VALUE) + + ' close the mixer + mixerClose(hMixer) + return true + +end function + +' get os fader volume app channel +function getvolumeosmixer() as ulong + + Dim hMixer As HMIXER + Dim mxlc As MIXERLINECONTROLS + Dim mxcd As MIXERCONTROLDETAILS + Dim mxcd_vol As MIXERCONTROLDETAILS_UNSIGNED + Dim mxl As MIXERLINE + Dim mxlc_vol As MIXERCONTROL + + ' Open the mixer + mixerOpen(@hMixer, 0, 0, 0, 0) + + ' get volume control for app channel + mxlc.cbStruct = SizeOf(MIXERLINECONTROLS) + mxlc.dwControlType = MIXERCONTROL_CONTROLTYPE_VOLUME + mxlc.cControls = 1 + mxlc.cbmxctrl = SizeOf(MIXERCONTROL) + mxlc.pamxctrl = @mxlc_vol + mixerGetLineControls(hMixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE) + + ' get fader volume app channel + mxcd.cbStruct = SizeOf(MIXERCONTROLDETAILS) + mxcd.dwControlID = mxlc_vol.dwControlID + mxcd.cChannels = 1 + mxcd.cMultipleItems = 0 + mxcd.cbDetails = SizeOf(MIXERCONTROLDETAILS_UNSIGNED) + mxcd.paDetails = @mxcd_vol + mixerGetControlDetails(hMixer, @mxcd, MIXER_GETCONTROLDETAILSF_VALUE) + + ' close the mixer + mixerClose(hMixer) + + ' return volume app channel + return mxcd_vol.dwValue + +end function + +' convert os fader volume app channel +' scale from 0 ~ 65535 to 0 ~ 100 (windows mixer) +function displayvolumeosmixer(volume as ulong) as integer + volume = volume / (65535 * 0.01) + return int(volume) +end function + ' init playback dim refreshinfo as boolean = true dim taginfo(1 to 5) as string dim firstmp3 as integer = 1 +dim musiclevel as single +dim sleeplength as integer = 1000 + getmp3cover(filename) -Mix_VolumeMusic(currentvolume) +Mix_VolumeMusic(sourcevolume) +currentvolume = getvolumeosmixer() cls Do Dim As String key = UCase(Inkey) + sleeplength = 25 + + ' ghetto attempt of dynamic range compression audio + if drc = "true" then + drcvolume = 128 + Mix_VolumeMusic(drcvolume) + else + Mix_VolumeMusic(sourcevolume) + end if Select Case key Case Chr$(32) @@ -438,7 +381,6 @@ Do getmp3cover(filename) music = Mix_LoadMUS(filename) Mix_PlayMusic(music,0) - tracklength = Mix_MusicDuration(music) erase taginfo refreshinfo = true cls @@ -449,7 +391,6 @@ Do getmp3cover(filename) music = Mix_LoadMUS(filename) Mix_PlayMusic(music,0) - tracklength = Mix_MusicDuration(music) erase taginfo refreshinfo = true cls @@ -468,57 +409,76 @@ Do Case "R" ' restart mp3 Mix_RewindMusic() + Case "L" + ' change list playtype + select case playtype + case "linear" + playtype = "shuffle" + case "shuffle" + playtype = "linear" + end select + Case "D" + ' toggle drc + select case drc + case "true" + drc = "false" + drcvolume = sourcevolume + case "false" + drc = "true" + end select Case "-" - ' decrease mp3 volume (in range [0.0, 128.0]) - if currentvolume > 1 and currentvolume < 129 then - currentvolume = currentvolume - 1 - Mix_VolumeMusic(currentvolume) - end if + ' decrease fader mixer os volume (in range 0 - 65535) + currentvolume = currentvolume - 1000 + if currentvolume < 1001 then currentvolume = 0 end if + setvolumeosmixer(currentvolume) Case "+" - ' increase mp3 volume (in range [0.0, 128.0]) - if currentvolume > 0 and currentvolume < 128 then - currentvolume = currentvolume + 1 - Mix_VolumeMusic(currentvolume) - end if + ' increase fader mixer os volume (in range 0 - 65535) + currentvolume = currentvolume + 1000 + if currentvolume > 65535 then currentvolume = 65535 end if + setvolumeosmixer(currentvolume) Case Chr(27) Exit Do + case else + ' detect volume change via os mixer + currentvolume = getvolumeosmixer() + sleeplength = 1000 End Select ' auto play next mp3 from list if applicable - if Mix_PlayingMusic() = 0 and maxitems > 1 and firstmp3 = 0 then - ' play next mp3 - Mix_FreeMusic(music) - filename = listplay(playtype, "music") - getmp3cover(filename) - music = Mix_LoadMUS(filename) - Mix_PlayMusic(music,0) - tracklength = Mix_MusicDuration(music) - refreshinfo = true - cls + if Mix_PlayingMusic() = 0 and maxitems > 1 and firstmp3 = 0 then + Mix_FreeMusic(music) + filename = listplay(playtype, "music") + getmp3cover(filename) + music = Mix_LoadMUS(filename) + Mix_PlayMusic(music,0) + refreshinfo = true + cls end if ' play with first song if firstmp3 = 1 then music = Mix_LoadMUS(filename) Mix_PlayMusic(music,0) - tracklength = Mix_MusicDuration(music) firstmp3 = 0 musicstate = true end if ' mp3 play time elapsed - secondsPosition = Mix_GetMusicPosition(music) - + secondsPosition = Mix_GetMusicPosition(music) + tracklength = Mix_MusicDuration(music) ' ascii interface - Locate currentLine, 1 + Locate 1, 1 ' basic interaction - Print "===== > SDL2 mixer library demonstration < =====" + Print "| SDL2 mixer library demonstration v" + exeversion + print Print "press . play next" Print "press , play previous" Print "press ] skip forward 10 secs" Print "press [ skip backwards 10 secs" Print "press space pause / play or mute / unmute" Print "press r restart" + Print "press l for linear / shuffle list play" + Print "press d for dynamic range compression not active for sdl" Print "press - increase volume" Print "press + decrease volume" Print "press esc quit" @@ -543,16 +503,21 @@ Do else print "current: " + mid(left(filename, len(filename) - instr(filename, "\") -1), InStrRev(filename, "\") + 1, len(filename)) end if - print "duration: " & compoundtime(tracklength) & " / " & compoundtime(CInt(secondsPosition)) + print "duration: " & compoundtime(tracklength) & " / " & compoundtime(CInt(secondsPosition)) & " " ' song list info - print "list: " & maxitems & " / " & compoundtime(listduration) + print "list: " & maxitems & " / " & compoundtime(listduration) & " " & playtype + " " print "file: " + filename if musicstate = false then - print using "volume: mute"; + print "volume: mute " else - print using "volume: ### "; currentvolume + print using "volume: &###-"; displayvolumeosmixer(currentvolume); + print " " end if - Sleep(30) + print using "drc: &###-"; drcvolume; + print " " & drc & " " + + Sleep(sleeplength) + Loop cleanup: @@ -562,7 +527,7 @@ delfile(exepath + "\" + "music" + ".lst") delfile(exepath + "\thumb.jpg") delfile(exepath + "\thumb.png") -' cleanup libs +' Free all resources allocated by SDL Mix_FreeMusic(music) Mix_CloseAudio() SDL_Quit() diff --git a/audioplayer.nfo b/audioplayer.nfo new file mode 100644 index 0000000..f004263 --- /dev/null +++ b/audioplayer.nfo @@ -0,0 +1,27 @@ +update v1.2 15/05/2023 +- added drc, dynamic range compression can be set via conf.ini +| placebo for now on sdl, sdl does not have a mechanism to +| measure signal level of audio as bass does. +- added toggle drc via key 'd' drc on or off (placeholder for now) +- added toggle listplay via key 'l' shuffle or linear +- added os mixer fader volume control (windows 7 and 10) +| route: sourcevolume > drcvolume (on / off) > currentvolume( is os mixer volume) +| source is set via config, drc amps Db currentvolume is final volume output +- improved command line handling catches incorrect files and paths +- tweaked utilfile.bas more in line with other apps +- tweaked shuffleplay scanning from root dir is not supported +- tieded up code in most files +- use init sdl with SDL_Init(SDL_INIT_AUDIO) instead of SDL_Init(SDL_INIT_VIDEO) +| SDL_Init(SDL_INIT_AUDIO) does not block os powerplan to blank display +| note: when using SDL_INIT_AUDIO use SDL_SetHint(SDL_HINT_VIDEO_ALLOW_SCREENSAVER, "1") +| respond to power plan settings blank display on windows +| note: set before sdl init (video) otherwise it will not work! +- fixed .pls + +update v1.1 20/03/2023 +- better thumbnail detection in jpeg + pattern ffd8 ffd8 ffd9 ffd9 next to + pattern ffd8 ffd9 ffd8 ffd9 +- better png check using exif as check +- removed p play option not really needed +- misc bugfixes stability and error handling diff --git a/conf.ini b/conf.ini index 50e4d7b..51ce5bf 100644 --- a/conf.ini +++ b/conf.ini @@ -12,9 +12,12 @@ logtype = verbose ' used for debug build usecons = false locale = en +' volume 0 to 128 defaultvolume = 32 ' options shuffle, linear -playtype = shuffle +playtype = linear +' dynamic range compression *currently not working with sdl +drc = false ' navigation settings [mouse] diff --git a/help-de.ini b/help-de.ini index f604277..3e75613 100644 --- a/help-de.ini +++ b/help-de.ini @@ -26,6 +26,10 @@ coverart von mp3 wird als thumb.jpg oder thumb.png extrahiert [ : 10 Sekunden rückwärts springen Leertaste : Pause / Wiedergabe oder Stummschaltung / Stummschaltung aufheben r : Neustart +l : lineare / Shuffle Listenwiedergabe +d : dynamic range compression* - : Lautstärke erhöhen + : Lautstärke verringern esc : beenden + +*) dynamic range compression currently does not work for sdl diff --git a/help-en.ini b/help-en.ini index f71d4b8..6b69aa4 100644 --- a/help-en.ini +++ b/help-en.ini @@ -25,7 +25,10 @@ coverart of mp3 is extracted as thumb.jpg or thumb.png [ : skip backwards 10 secs space : pause / play or mute / unmute r : restart +l : linear / shuffle list play +d : dynamic range compression* - : increase volume + : decrease volume esc : quit +*) dynamic range compression currently does not work for sdl diff --git a/readme.md b/readme.md index 458af24..9bb9ce5 100644 --- a/readme.md +++ b/readme.md @@ -8,6 +8,8 @@ basic config options in conf.ini\ locale = \ defaultvolume = <1 .. 128>\ playtype = \ +' dynamic range compression *currently not working with sdl\ +drc = \ \ basic help localization via:\ help-de.ini\ @@ -65,6 +67,8 @@ press ] to skip forward 10 secs\ press [ to skip backwards 10 secs\ press space to pause / play or mute / unmute\ press r to restart\ +press l for linear / shuffle list play\ +press d for dynamic range compression *note currently not working for sdl\ press - to increase volume\ press + to decrease volume\ press esc to quit\ diff --git a/shuffleplay.bas b/shuffleplay.bas index 7f312bd..c97fc93 100644 --- a/shuffleplay.bas +++ b/shuffleplay.bas @@ -1,15 +1,15 @@ ' based on recursive dir code of coderjeff https://www.freebasic.net/forum/viewtopic.php?t=5758 function createlist(folder as string, filterext as string, listname as string) as integer ' setup filelist - dim chk as boolean - redim path(1 to 1) As string dim as integer i = 1, n = 1, attrib - dim file as string - dim fileext as string - dim maxfiles as integer - dim f as integer + redim path(1 to 1) as string + dim chk as boolean + dim file as string + dim fileext as string + dim maxfiles as integer + dim f as integer f = freefile - dim filelist as string = exepath + "\" + listname + ".tmp" + dim filelist as string = exepath + "\" + listname + ".tmp" open filelist for output as #f #ifdef __FB_LINUX__ @@ -32,18 +32,23 @@ function createlist(folder as string, filterext as string, listname as string) a while file > "" if (attrib and fbDirectory) then if file <> "." and file <> ".." then - n += 1 - redim preserve path(1 to n) - path(n) = path(i) + file + pathchar + ' todo evaluate limit recursive if starting folder is root + if len(path(1)) > 3 then + n += 1 + redim preserve path(1 to n) + path(n) = path(i) + file + pathchar + else + logentry("terminate", "scanning from root dir not supported! " + path(i)) + end if end if else fileext = lcase(mid(file, instrrev(file, "."))) - if instr(1, filterext, fileext) > 0 and len(fileext) > 3 then + if instr(1, filterext, fileext) > 0 and len(fileext) > 3 then print #f, path(i) & file maxfiles += 1 else logentry("warning", "file format not supported - " + path(i) & file) - end if + end if end if file = dir(@attrib) wend @@ -65,24 +70,24 @@ function createlist(folder as string, filterext as string, listname as string) a end function -dim shared currentimage as integer -dim shared currentsong as integer +dim shared currentimage as integer +dim shared currentsong as integer dim shared currentshader as integer ' video shuffle is handeld by mpv -dim shared currentvideo as integer +dim shared currentvideo as integer ' todo fix currentimage for music function listplay (playtype as string, listname as string) as string ' setup item file and item count - dim tmp as integer - dim chk as boolean - Dim listitem as string + dim tmp as integer + dim chk as boolean + Dim listitem as string Dim currentitem as integer - dim itemnr as integer = 1 - dim maxitems as integer = 0 - dim baseitem as integer - dim lastitem as string = exepath + "\" + listname + ".lst" - dim tempfile as string = exepath + "\" + listname + ".tmp" + dim itemnr as integer = 1 + dim maxitems as integer = 0 + dim baseitem as integer + dim lastitem as string = exepath + "\" + listname + ".lst" + dim tempfile as string = exepath + "\" + listname + ".tmp" ' work around for multiple lists todo improve select case listname diff --git a/utilfile.bas b/utilfile.bas index 969d403..44182e2 100644 --- a/utilfile.bas +++ b/utilfile.bas @@ -12,11 +12,11 @@ 'Dim Shared _dowildcard As Long = 0 ' setup log -dim shared logfile as string -dim shared logtype as string -dim shared appname as string -dim shared appfile as string -dim shared usecons as string +dim shared logfile as string +dim shared logtype as string +dim shared appname as string +dim shared appfile as string +dim shared usecons as string dim shared exeversion as string ' note command(0) can arbitraly add the path so strip it @@ -58,6 +58,9 @@ os = "unknown" os = "unix" #endif +' metric functions +' ______________________________________________________________________________' + ' used for logging Function logentry(entrytype As String, logmsg As String) As Boolean @@ -98,12 +101,92 @@ Function logentry(entrytype As String, logmsg As String) As Boolean ' normal termination or fatal error if entrytype = "terminate" then + print logmsg end end if return true End function +' localiztion can be applied by getting a locale or other method +dim locale as string = "en" +sub displayhelp(locale as string) + dim dummy as string + dim f as integer + f = freefile + + ' get / set locale + select case locale + case "de" + locale = "de" + case "en" + ' default locale + case else + locale = "en" + end select + ' get text + Open exepath + "\help-" + locale + ".ini" For input As #f + Do Until EOF(f) + Line Input #f, dummy + print dummy + Loop + close f + +end sub + +' get fileversion executable or dll windows only +function getfileversion(versinfo() as string, versdesc() as string) as integer + + dim as integer bytesread,c,dwHandle,res,verSize + dim as string buffer,ls,qs,tfn + dim as ushort ptr b1,b2 + dim as ubyte ptr bptr + + tfn=versinfo(8) + if dir(tfn)="" then return -1 + verSize=GetFileVersionInfoSize(tfn,@dwHandle) + if verSize=0 then return -2 + dim as any ptr verdat=callocate(verSize*2) + + res=GetFileVersionInfo(strptr(tfn),dwHandle,verSize*2,verdat) + res=_ + VerQueryValue(_ + verdat,_ + "\VarFileInfo\Translation",_ + @bptr,_ + @bytesread) + + if bytesread=0 then deallocate(verdat):return -3 + + b1=cast(ushort ptr,bptr) + b2=cast(ushort ptr,bptr+2) + ls=hex(*b1,4)& hex(*b2,4) + + for c=0 to 7 + qs="\StringFileInfo\" & ls & "\" & versdesc(c) + res=_ + VerQueryValue(_ + verdat,_ + strptr(qs),_ + @bptr,_ + @bytesread) + if bytesread>0 then + buffer=space(bytesread) + CopyMemory(strptr(buffer),bptr,bytesread) + versinfo(c)=buffer + else + versinfo(c)="N/A" + end if + next c + deallocate(verdat) + + return 1 + +end function + +' generic file functions +' ______________________________________________________________________________' + ' list files in folder function getfilesfromfolder (filespec As String) as boolean Dim As String filename = Dir(filespec, 1) @@ -219,6 +302,9 @@ Function checkpath(chkpath As String) As boolean End Function +' file type specific functions +' ______________________________________________________________________________' + ' cheap xml reading Function readxmlfile(filename as string, element as string) As boolean @@ -389,10 +475,10 @@ End Function ' cheap ini file reader Function readini(filename as string) as boolean - dim itm as string + dim itm as string dim inikey as string dim inival as string - dim f as integer + dim f as integer f = readfromfile(filename) Do Until EOF(f) Line Input #f, itm @@ -406,6 +492,310 @@ Function readini(filename as string) as boolean return true end function +' code by squall4226 +' see https://www.freebasic.net/forum/viewtopic.php?p=149207&hilit=user+need+TALB+for+album#p149207 +Function getmp3tag(searchtag As String, fn As String) As String + 'so we can avoid having the user need TALB for album, TIT2 for title etc, although they are accepted + Dim As Integer skip, offset' in order to read certain things right + Dim As UInteger sig_to_find, count, fnum, maxcheck = 100000 + dim as UShort tag_length + Dim As UShort unitest, mp3frametest + Dim As String tagdata + + Select Case UCase(searchtag) + Case "HEADER", "ID3" + searchtag = "ID3" & Chr(&h03) + Case "TITLE", "TIT2" + searchtag = "TIT2" + Case "ARTIST", "TPE1" + searchtag = "TPE1" + Case "ALBUM", "TALB" + searchtag = "TALB" + Case "COMMENT", "COMM" + searchtag = "COMM" + Case "COPYRIGHT", "TCOP" + searchtag = "TCOP" + Case "COMPOSER", "TCOM" + searchtag = "TCOM" + Case "BEATS PER MINUTE", "BPM", "TPBM" + searchtag = "TBPM" + Case "PUBLISHER", "TPUB" + searchtag = "TPUB" + Case "URL", "WXXX" + searchtag = "WXXX" + Case "PLAY COUNT" "PCNT" + searchtag = "PCNT" + Case "GENRE", "TCON" + searchtag = "TCON" + Case "ENCODER", "TENC" + searchtag = "TENC" + Case "TRACK", "TRACK NUMBER", "TRCK" + searchtag = "TRCK" + Case "YEAR", "TYER" + searchtag = "TYER" + 'Special, in this case we will return the datasize if present, or "-1" if no art + Case "PICTURE", "APIC" + searchtag = "APIC" + 'Not implemented yet! + Case Else + 'Tag may be invalid, but search anyway, there are MANY tags, and we have error checking + End Select + + fnum = FreeFile + Open fn For Binary Access Read As #fnum + If Lof(fnum) < maxcheck Then maxcheck = Lof(fnum) + For count = 0 to maxcheck Step 1 + Get #fnum, count, sig_to_find + If sig_to_find = Cvi(searchtag) Then + If searchtag = "ID3" & Chr(&h03) Then + Close #fnum + Return "1" 'Because there is no data here, we were just checking for the ID3 header + EndIf + 'test for unicode + Get #fnum, count+11, unitest + If unitest = &hFEFF Then 'unicode string + skip = 4 + offset = 13 + Else 'not unicode string + skip = 0 + offset = 10 + EndIf + + Get #fnum, count +7, tag_length 'XXXXYYYZZ Where XXXX is the TAG, YYY is flags or something, ZZ is size + + If tag_length-skip < 1 Then + Close #fnum + Return "ERROR" 'In case of bad things + EndIf + + Dim As Byte dataget(1 To tag_length-skip) + Get #fnum, count+offset, dataget() + + For i As Integer = 1 To tag_length - skip + if dataget(i) < 4 then dataget(i) = 0 ' remove odd characters + If dataget(i) <> 0 Then tagdata + = Chr(dataget(i)) 'remove null spaces from ASCII data in UNICODE string + Next + End If + If tagdata <> "" then exit For ' stop searching! + Next + Close #fnum + + If Len(tagdata) = 0 Then + 'If the tag was just not found or had no data then "----" + tagdata = "----" + EndIf + + Return tagdata + +End Function + +' attempt to extract and write cover art of mp3 to temp thumb file +Function getmp3cover(filename As String) As boolean + Dim buffer As String + dim chunk as string + dim length as string + dim bend as integer + dim ext as string = "" + dim thumb as string + ' remove old thumb if present + delfile(exepath + "\thumb.jpg") + delfile(exepath + "\thumb.png") + Open filename For Binary Access Read As #1 + If LOF(1) > 0 Then + buffer = String(LOF(1), 0) + Get #1, , buffer + End If + Close #1 + if instr(1, buffer, "APIC") > 0 then + length = mid(buffer, instr(buffer, "APIC") + 4, 4) + ' ghetto check funky first 4 bytes signifying length image + ' not sure how reliable this info is + ' see comment codecaster https://stackoverflow.com/questions/47882569/id3v2-tag-issue-with-apic-in-c-net + if val(asc(length, 1) & asc(length, 2)) = 0 then + bend = (asc(length, 3) shl 8) or asc(length, 4) + else + bend = (asc(length, 1) shl 24 + asc(length, 2) shl 16 + asc(length, 3) shl 8 or asc(length, 4)) + end if + if instr(1, buffer, "JFIF") > 0 then + ' override end jpg if marker FFD9 is present + if instr(buffer, CHR(&hFF, &hD9)) > 0 then + bend = instr(1, mid(buffer, instr(1, buffer, "JFIF")), CHR(&hFF, &hD9)) + 7 + end if + chunk = mid(buffer, instr(buffer, "JFIF") - 6, bend) + ' thumbnail detection + if instr(instr(1, buffer, "JFIF") + 4, buffer, "JFIF") > 0 then + chunk = mid(buffer, instr(10, buffer, CHR(&hFF, &hD8)), instr(instr(buffer, CHR(&hFF, &hD9)) + 1, buffer, CHR(&hFF, &hD9)) - (instr(10, buffer, CHR(&hFF, &hD8)) - 2)) + ' thumbnail in thumbnail edge case ffd8 ffd8 ffd9 ffd9 pattern in jpeg + if instr(chunk, CHR(&hFF, &hD8, &hFF)) > 0 then + chunk = mid(buffer,_ + instr(1,buffer, CHR(&hFF, &hD8)),_ + instr(instr(instr(instr(1,buffer, CHR(&hFF, &hD9)) + 1, buffer, CHR(&hFF, &hD9)) + 1, buffer, CHR(&hFF, &hD9))_ + , buffer, CHR(&hFF, &hD9)) + 2 - instr(buffer, CHR(&hFF, &hD8))) + end if + end if + ext = ".jpg" + end if + ' use ext and exif check to catch false png + if instr(1, buffer, "‰PNG") > 0 and instr(1, buffer, "Exif") = 0 and ext = "" then + ' override end png if tag is present + if instr(1, buffer, "IEND") > 0 then + bend = instr(1, mid(buffer, instr(1, buffer, "‰PNG")), "IEND") + 7 + end if + chunk = mid(buffer, instr(buffer, "‰PNG"), bend) + ext = ".png" + end if + ' funky variant for non jfif and jpegs video encoding? + if (instr(1, buffer, "Lavc58") > 0 or instr(1, buffer, "Exif") > 0) and ext = "" then + ' override end jpg if marker FFD9 is present + if instr(buffer, CHR(&hFF, &hD9)) > 0 then + bend = instr(1, mid(buffer, instr(1, buffer, "Exif")), CHR(&hFF, &hD9)) + 7 + end if + if instr(1, buffer, "Exif") > 0 then + chunk = mid(buffer, instr(buffer, "Exif") - 6, bend) + else + chunk = mid(buffer, instr(buffer, "Lavc58") - 6, bend) + end if + ext = ".jpg" + end if + ' last resort just check on begin and end marker very tricky... + ' see https://stackoverflow.com/questions/4585527/detect-end-of-file-for-jpg-images#4614629 + if instr(buffer, CHR(&hFF, &hD8)) > 0 and ext = ""then + chunk = mid(buffer, instr(1, buffer, CHR(&hFF, &hD8)), instr(1, buffer, CHR(&hFF, &hD9))) + ext = ".jpg" + end if + buffer = "" + Close #1 + ' attempt to write thumbnail to temp file + if ext <> "" then + thumb = exepath + "\thumb" + ext + open thumb for Binary Access Write as #1 + put #1, , chunk + close #1 + else + ' no cover art in mp3 optional use folder.jpg if present as thumb + end if + return true + else + ' no cover art in mp3 optional use folder.jpg if present as thumb + logentry("notice", "no cover art found in: " + filename) + return false + end if +end function + +' MD5 encrypt from the Wikipedia page "MD5" +' compile with: fbc -s console +' from https://rosettacode.org/wiki/MD5/Implementation#FreeBASIC +' note md5 is not reversible, at least it shouldn't be... +' added basic file i/o thrive4 2022 + +' macro for a rotate left +#Macro ROtate_Left (x, n) ' rotate left + (x) = (x) Shl (n) + (x) Shr (32 - (n)) +#EndMacro + +Function MD5(test_str As String) As String + + Dim As String message = test_str ' strings are passed as ByRef's + + Dim As UByte sx, s(0 To ...) = { 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, _ + 17, 22, 7, 12, 17, 22, 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, _ + 5, 9, 14, 20, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, _ + 16, 23, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21 } + + Dim As UInteger<32> K(0 To ...) = { &Hd76aa478, &He8c7b756, &H242070db, _ + &Hc1bdceee, &Hf57c0faf, &H4787c62a, &Ha8304613, &Hfd469501, &H698098d8, _ + &H8b44f7af, &Hffff5bb1, &H895cd7be, &H6b901122, &Hfd987193, &Ha679438e, _ + &H49b40821, &Hf61e2562, &Hc040b340, &H265e5a51, &He9b6c7aa, &Hd62f105d, _ + &H02441453, &Hd8a1e681, &He7d3fbc8, &H21e1cde6, &Hc33707d6, &Hf4d50d87, _ + &H455a14ed, &Ha9e3e905, &Hfcefa3f8, &H676f02d9, &H8d2a4c8a, &Hfffa3942, _ + &H8771f681, &H6d9d6122, &Hfde5380c, &Ha4beea44, &H4bdecfa9, &Hf6bb4b60, _ + &Hbebfbc70, &H289b7ec6, &Heaa127fa, &Hd4ef3085, &H04881d05, &Hd9d4d039, _ + &He6db99e5, &H1fa27cf8, &Hc4ac5665, &Hf4292244, &H432aff97, &Hab9423a7, _ + &Hfc93a039, &H655b59c3, &H8f0ccc92, &Hffeff47d, &H85845dd1, &H6fa87e4f, _ + &Hfe2ce6e0, &Ha3014314, &H4e0811a1, &Hf7537e82, &Hbd3af235, &H2ad7d2bb, _ + &Heb86d391 } + + ' Initialize variables + Dim As UInteger<32> A, a0 = &H67452301 + Dim As UInteger<32> B, b0 = &Hefcdab89 + Dim As UInteger<32> C, c0 = &H98badcfe + Dim As UInteger<32> D, d0 = &H10325476 + Dim As UInteger<32> dtemp, F, g, temp + + Dim As Long i, j + + Dim As ULongInt l = Len(message) + ' set the first bit after the message to 1 + message = message + Chr(1 Shl 7) + ' add one char to the length + Dim As ULong padding = 64 - ((l +1) Mod (512 \ 8)) ' 512 \ 8 = 64 char. + + ' check if we have enough room for inserting the length + If padding < 8 Then padding = padding + 64 + + message = message + String(padding, Chr(0)) ' adjust length + Dim As ULong l1 = Len(message) ' new length + + l = l * 8 ' orignal length in bits + ' create ubyte ptr to point to l ( = length in bits) + Dim As UByte Ptr ub_ptr = Cast(UByte Ptr, @l) + + For i = 0 To 7 'copy length of message to the last 8 bytes + message[l1 -8 + i] = ub_ptr[i] + Next + + For j = 0 To (l1 -1) \ 64 ' split into block of 64 bytes + + A = a0 : B = b0 : C = c0 : D = d0 + + ' break chunk into 16 32bit uinteger + Dim As UInteger<32> Ptr M = Cast(UInteger<32> Ptr, @message[j * 64]) + + For i = 0 To 63 + Select Case As Const i + Case 0 To 15 + F = (B And C) Or ((Not B) And D) + g = i + Case 16 To 31 + F = (B And D) Or (C And (Not D)) + g = (i * 5 +1) Mod 16 + Case 32 To 47 + F = (B Xor C Xor D) + g = (i * 3 +5) Mod 16 + Case 48 To 63 + F = C Xor (B Or (Not D)) + g = (i * 7) Mod 16 + End Select + dtemp = D + D = C + C = B + temp = A + F + K(i)+ M[g] : ROtate_left(temp, s(i)) + B = B + temp + A = dtemp + Next + + a0 += A : b0 += B : c0 += C : d0 += D + + Next + + Dim As String answer + ' convert a0, b0, c0 and d0 in hex, then add, low order first + Dim As String s1 = Hex(a0, 8) + For i = 7 To 1 Step -2 : answer +=Mid(s1, i, 2) : Next + s1 = Hex(b0, 8) + For i = 7 To 1 Step -2 : answer +=Mid(s1, i, 2) : Next + s1 = Hex(c0, 8) + For i = 7 To 1 Step -2 : answer +=Mid(s1, i, 2) : Next + s1 = Hex(d0, 8) + For i = 7 To 1 Step -2 : answer +=Mid(s1, i, 2) : Next + + Return LCase(answer) + +End Function + +' text related functions +' ______________________________________________________________________________' + ' split or explode by delimiter return elements in array ' based on https://www.freebasic.net/forum/viewtopic.php?t=31691 code by grindstone Function explode(haystack As String = "", delimiter as string, ordinance() As String) As UInteger @@ -434,109 +824,6 @@ Function explode(haystack As String = "", delimiter as string, ordinance() As St End Function -' get fileversion executable or dll windows only -function getfileversion(versinfo() as string, versdesc() as string) as integer - - dim as integer bytesread,c,dwHandle,res,verSize - dim as string buffer,ls,qs,tfn - dim as ushort ptr b1,b2 - dim as ubyte ptr bptr - - tfn=versinfo(8) - if dir(tfn)="" then return -1 - verSize=GetFileVersionInfoSize(tfn,@dwHandle) - if verSize=0 then return -2 - dim as any ptr verdat=callocate(verSize*2) - - res=GetFileVersionInfo(strptr(tfn),dwHandle,verSize*2,verdat) - res=_ - VerQueryValue(_ - verdat,_ - "\VarFileInfo\Translation",_ - @bptr,_ - @bytesread) - - if bytesread=0 then deallocate(verdat):return -3 - - b1=cast(ushort ptr,bptr) - b2=cast(ushort ptr,bptr+2) - ls=hex(*b1,4)& hex(*b2,4) - - for c=0 to 7 - qs="\StringFileInfo\" & ls & "\" & versdesc(c) - res=_ - VerQueryValue(_ - verdat,_ - strptr(qs),_ - @bptr,_ - @bytesread) - if bytesread>0 then - buffer=space(bytesread) - CopyMemory(strptr(buffer),bptr,bytesread) - versinfo(c)=buffer - else - versinfo(c)="N/A" - end if - next c - deallocate(verdat) - - return 1 - -end function - -' get fileversion executable via .rc #cmdline -function getfileversionraw(filename as string) as string - dim itm as string - dim inikey as string - dim inival as string - dim f as integer - f = readfromfile(filename) - Do Until EOF(f) - Line Input #f, itm - if instr(1, itm, "FILEVERSION") > 0 then - 'inikey = trim(mid(itm, 1, instr(1, itm, "=") - 2)) - inival = trim(mid(itm, instr(1, itm, "FILEVERSION") + 11, len(itm))) - inival = replace(inival, " ", "") - inival = replace(inival, ",", ".") - 'print inikey + " - " + inival - exit do - else - inival = "unknown" - end if - loop - close f - return inival - -end function - -' localiztion can be applied by getting a locale or other method -sub displayhelp(locale as string) - dim dummy as string - dim f as integer - f = freefile - - ' get / set locale - select case locale - case "de" - locale = "de" - case "en" - ' default locale - case else - locale = "en" - end select - ' get text - Open exepath + "\help-" + locale + ".ini" For input As #f - Do Until EOF(f) - Line Input #f, dummy - print dummy - Loop - close f - -end sub - -' text related functions -' ______________________________________________________________________________' - ' setup word wrap string type stringwrap as integer linecnt ' current line @@ -549,10 +836,10 @@ type stringwrap end type dim swp as stringwrap -swp.linecnt = 1 -swp.linemax = 10 +swp.linecnt = 1 +swp.linemax = 10 swp.linelength = 70 -swp.wrapchar = " ,.?;-" +swp.wrapchar = " ,.?;-" function replace(byref haystack as string, byref needle as string, byref substitute as string) as string 'found at https://freebasic.net/forum/viewtopic.php?f=2&t=9971&p=86259&hilit=replace+character+in+string#p86259 @@ -634,114 +921,3 @@ function wordwrap2file(filename as string, swp as stringwrap) as boolean return true end function - -' MD5 encrypt from the Wikipedia page "MD5" -' compile with: fbc -s console -' from https://rosettacode.org/wiki/MD5/Implementation#FreeBASIC -' note md5 is not reversible, at least it shouldn't be... -' added basic file i/o thrive4 2022 - -' macro for a rotate left -#Macro ROtate_Left (x, n) ' rotate left - (x) = (x) Shl (n) + (x) Shr (32 - (n)) -#EndMacro - -Function MD5(test_str As String) As String - - Dim As String message = test_str ' strings are passed as ByRef's - - Dim As UByte sx, s(0 To ...) = { 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, _ - 17, 22, 7, 12, 17, 22, 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, _ - 5, 9, 14, 20, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, _ - 16, 23, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21 } - - Dim As UInteger<32> K(0 To ...) = { &Hd76aa478, &He8c7b756, &H242070db, _ - &Hc1bdceee, &Hf57c0faf, &H4787c62a, &Ha8304613, &Hfd469501, &H698098d8, _ - &H8b44f7af, &Hffff5bb1, &H895cd7be, &H6b901122, &Hfd987193, &Ha679438e, _ - &H49b40821, &Hf61e2562, &Hc040b340, &H265e5a51, &He9b6c7aa, &Hd62f105d, _ - &H02441453, &Hd8a1e681, &He7d3fbc8, &H21e1cde6, &Hc33707d6, &Hf4d50d87, _ - &H455a14ed, &Ha9e3e905, &Hfcefa3f8, &H676f02d9, &H8d2a4c8a, &Hfffa3942, _ - &H8771f681, &H6d9d6122, &Hfde5380c, &Ha4beea44, &H4bdecfa9, &Hf6bb4b60, _ - &Hbebfbc70, &H289b7ec6, &Heaa127fa, &Hd4ef3085, &H04881d05, &Hd9d4d039, _ - &He6db99e5, &H1fa27cf8, &Hc4ac5665, &Hf4292244, &H432aff97, &Hab9423a7, _ - &Hfc93a039, &H655b59c3, &H8f0ccc92, &Hffeff47d, &H85845dd1, &H6fa87e4f, _ - &Hfe2ce6e0, &Ha3014314, &H4e0811a1, &Hf7537e82, &Hbd3af235, &H2ad7d2bb, _ - &Heb86d391 } - - ' Initialize variables - Dim As UInteger<32> A, a0 = &H67452301 - Dim As UInteger<32> B, b0 = &Hefcdab89 - Dim As UInteger<32> C, c0 = &H98badcfe - Dim As UInteger<32> D, d0 = &H10325476 - Dim As UInteger<32> dtemp, F, g, temp - - Dim As Long i, j - - Dim As ULongInt l = Len(message) - ' set the first bit after the message to 1 - message = message + Chr(1 Shl 7) - ' add one char to the length - Dim As ULong padding = 64 - ((l +1) Mod (512 \ 8)) ' 512 \ 8 = 64 char. - - ' check if we have enough room for inserting the length - If padding < 8 Then padding = padding + 64 - - message = message + String(padding, Chr(0)) ' adjust length - Dim As ULong l1 = Len(message) ' new length - - l = l * 8 ' orignal length in bits - ' create ubyte ptr to point to l ( = length in bits) - Dim As UByte Ptr ub_ptr = Cast(UByte Ptr, @l) - - For i = 0 To 7 'copy length of message to the last 8 bytes - message[l1 -8 + i] = ub_ptr[i] - Next - - For j = 0 To (l1 -1) \ 64 ' split into block of 64 bytes - - A = a0 : B = b0 : C = c0 : D = d0 - - ' break chunk into 16 32bit uinteger - Dim As UInteger<32> Ptr M = Cast(UInteger<32> Ptr, @message[j * 64]) - - For i = 0 To 63 - Select Case As Const i - Case 0 To 15 - F = (B And C) Or ((Not B) And D) - g = i - Case 16 To 31 - F = (B And D) Or (C And (Not D)) - g = (i * 5 +1) Mod 16 - Case 32 To 47 - F = (B Xor C Xor D) - g = (i * 3 +5) Mod 16 - Case 48 To 63 - F = C Xor (B Or (Not D)) - g = (i * 7) Mod 16 - End Select - dtemp = D - D = C - C = B - temp = A + F + K(i)+ M[g] : ROtate_left(temp, s(i)) - B = B + temp - A = dtemp - Next - - a0 += A : b0 += B : c0 += C : d0 += D - - Next - - Dim As String answer - ' convert a0, b0, c0 and d0 in hex, then add, low order first - Dim As String s1 = Hex(a0, 8) - For i = 7 To 1 Step -2 : answer +=Mid(s1, i, 2) : Next - s1 = Hex(b0, 8) - For i = 7 To 1 Step -2 : answer +=Mid(s1, i, 2) : Next - s1 = Hex(c0, 8) - For i = 7 To 1 Step -2 : answer +=Mid(s1, i, 2) : Next - s1 = Hex(d0, 8) - For i = 7 To 1 Step -2 : answer +=Mid(s1, i, 2) : Next - - Return LCase(answer) - -End Function