From cb4a46e7fbe62d788e66ed6121c717a2d22a4d7c Mon Sep 17 00:00:00 2001 From: watcherhd Date: Thu, 21 Apr 2011 14:14:52 +0000 Subject: svn.miranda.im is moving to a new home! git-svn-id: http://miranda-plugins.googlecode.com/svn/trunk@7 e753b5eb-9565-29b2-b5c5-2cc6f99dfbcb --- delphi/Awkward/utils/appcmdapi.pas | 97 ++ delphi/Awkward/utils/base64.pas | 108 ++ delphi/Awkward/utils/cbex.pas | 79 ++ delphi/Awkward/utils/common.pas | 2116 +++++++++++++++++++++++++++++++++++ delphi/Awkward/utils/compilers.inc | 735 ++++++++++++ delphi/Awkward/utils/dbsettings.pas | 421 +++++++ delphi/Awkward/utils/hotkeys.pas | 571 ++++++++++ delphi/Awkward/utils/ini.pas | 857 ++++++++++++++ delphi/Awkward/utils/io.pas | 249 +++++ delphi/Awkward/utils/mirutils.pas | 1026 +++++++++++++++++ delphi/Awkward/utils/playlist.pas | 431 +++++++ delphi/Awkward/utils/protocols.pas | 573 ++++++++++ delphi/Awkward/utils/syswin.pas | 734 ++++++++++++ delphi/Awkward/utils/utils.pas | 44 + delphi/Awkward/utils/wrapper.pas | 450 ++++++++ 15 files changed, 8491 insertions(+) create mode 100644 delphi/Awkward/utils/appcmdapi.pas create mode 100644 delphi/Awkward/utils/base64.pas create mode 100644 delphi/Awkward/utils/cbex.pas create mode 100644 delphi/Awkward/utils/common.pas create mode 100644 delphi/Awkward/utils/compilers.inc create mode 100644 delphi/Awkward/utils/dbsettings.pas create mode 100644 delphi/Awkward/utils/hotkeys.pas create mode 100644 delphi/Awkward/utils/ini.pas create mode 100644 delphi/Awkward/utils/io.pas create mode 100644 delphi/Awkward/utils/mirutils.pas create mode 100644 delphi/Awkward/utils/playlist.pas create mode 100644 delphi/Awkward/utils/protocols.pas create mode 100644 delphi/Awkward/utils/syswin.pas create mode 100644 delphi/Awkward/utils/utils.pas create mode 100644 delphi/Awkward/utils/wrapper.pas (limited to 'delphi/Awkward/utils') diff --git a/delphi/Awkward/utils/appcmdapi.pas b/delphi/Awkward/utils/appcmdapi.pas new file mode 100644 index 0000000..b316838 --- /dev/null +++ b/delphi/Awkward/utils/appcmdapi.pas @@ -0,0 +1,97 @@ +unit appcmdapi; +interface + +uses windows; + +const + APPCOMMAND_BROWSER_BACKWARD = 1; // Navigate backward. + APPCOMMAND_BROWSER_FORWARD = 2; // Navigate forward. + APPCOMMAND_BROWSER_REFRESH = 3; // Refresh page. + APPCOMMAND_BROWSER_STOP = 4; // Stop download. + APPCOMMAND_BROWSER_SEARCH = 5; // Open search. + APPCOMMAND_BROWSER_FAVORITES = 6; // Open favorites. + APPCOMMAND_BROWSER_HOME = 7; // Navigate home. + APPCOMMAND_VOLUME_MUTE = 8; // Mute the volume. + APPCOMMAND_VOLUME_DOWN = 9; // Lower the volume. + APPCOMMAND_VOLUME_UP = 10; // Raise the volume + APPCOMMAND_MEDIA_NEXTTRACK = 11; // Go to next track. + APPCOMMAND_MEDIA_PREVIOUSTRACK = 12; // Go to previous track. + APPCOMMAND_MEDIA_STOP = 13; // Stop playback. + APPCOMMAND_MEDIA_PLAY_PAUSE = 14; // Play or pause playback. If there are discrete Play + // and Pause buttons, applications should take action + // on this command as well as APPCOMMAND_MEDIA_PLAY and + // APPCOMMAND_MEDIA_PAUSE. + APPCOMMAND_LAUNCH_MAIL = 15; // Open mail. + APPCOMMAND_LAUNCH_MEDIA_SELECT = 16; // Go to Media Select mode + APPCOMMAND_MEDIA_SELECT = APPCOMMAND_LAUNCH_MEDIA_SELECT; + APPCOMMAND_LAUNCH_APP1 = 17; // Start App1. + APPCOMMAND_LAUNCH_APP2 = 18; // Start App2. + APPCOMMAND_BASS_DOWN = 19; // Decrease the bass. + APPCOMMAND_BASS_BOOST = 20; // Toggle the bass boost on and off. + APPCOMMAND_BASS_UP = 21; // Increase the bass. + APPCOMMAND_TREBLE_DOWN = 22; // Decrease the treble. + APPCOMMAND_TREBLE_UP = 23; // Increase the treble. + + APPCOMMAND_MICROPHONE_VOLUME_MUTE = 24; // Windows XP: Mute the microphone. + APPCOMMAND_MICROPHONE_VOLUME_DOWN = 25; // Windows XP: Decrease microphone volume. + APPCOMMAND_MICROPHONE_VOLUME_UP = 26; // Windows XP: Increase microphone volume. + APPCOMMAND_HELP = 27; // Windows XP: Open the Help dialog. + APPCOMMAND_FIND = 28; // Windows XP: Open the Find dialog. + APPCOMMAND_NEW = 29; // Windows XP: Create a new window. + APPCOMMAND_OPEN = 30; // Windows XP: Open a window. + APPCOMMAND_CLOSE = 31; // Windows XP: Close the window (not the application). + APPCOMMAND_SAVE = 32; // Windows XP: Save current document. + APPCOMMAND_PRINT = 33; // Windows XP: Print current document. + APPCOMMAND_UNDO = 34; // Windows XP: Undo last action. + APPCOMMAND_REDO = 35; // Windows XP: Redo last action. + APPCOMMAND_COPY = 36; // Windows XP: Copy the selection. + APPCOMMAND_CUT = 37; // Windows XP: Cut the selection. + APPCOMMAND_PASTE = 38; // Windows XP: Paste + APPCOMMAND_REPLY_TO_MAIL = 39; // Windows XP: Reply to a mail message. + APPCOMMAND_FORWARD_MAIL = 40; // Windows XP: Forward a mail message. + APPCOMMAND_SEND_MAIL = 41; // Windows XP: Send a mail message. + APPCOMMAND_SPELL_CHECK = 42; // Windows XP: Initiate a spell check. + APPCOMMAND_DICTATE_OR_COMMAND_CONTROL_TOGGLE = 43; + // Windows XP:Toggles between two modes of speech input: dictation and command/control + // (giving commands to an application or accessing menus). + APPCOMMAND_MIC_ON_OFF_TOGGLE = 44; // Windows XP: Toggle the microphone. + APPCOMMAND_CORRECTION_LIST = 45; // Windows XP: Brings up the correction list when + // a word is incorrectly identified during speech input. + + APPCOMMAND_MEDIA_PLAY = 46; // Windows XP SP1: Begin playing at the current position. + // If already paused, it will resume. This is a direct + // PLAY command that has no state. If there are + // discrete Play and Pause buttons, applications should + // take action on this command as well as + // APPCOMMAND_MEDIA_PLAY_PAUSE. + APPCOMMAND_MEDIA_PAUSE = 47; // Windows XP SP1: Pause. If already paused, take no + // further action. This is a direct PAUSE command that + // has no state. If there are discrete Play and Pause + // buttons, applications should take action on this + // command as well as APPCOMMAND_MEDIA_PLAY_PAUSE. + APPCOMMAND_MEDIA_RECORD = 48; // Windows XP SP1: Begin recording the current stream. + APPCOMMAND_MEDIA_FAST_FORWARD = 49; // Windows XP SP1: Increase the speed of stream playback. + // This can be implemented in many ways, for example, + // using a fixed speed or toggling through a series of + // increasing speeds. + APPCOMMAND_MEDIA_REWIND = 50; // Windows XP SP1: Go backward in a stream at a higher + // rate of speed. This can be implemented in many ways, + // for example, using a fixed speed or toggling through + // a series of increasing speeds. + APPCOMMAND_MEDIA_CHANNEL_UP = 51; // Windows XP SP1: Increment the channel value. + APPCOMMAND_MEDIA_CHANNEL_DOWN = 52; // Windows XP SP1: Decrement the channel value. + +function SendMMCommand(wnd:HWND; cmd:integer):integer; + +implementation + +const + WM_APPCOMMAND = $0319; + +function SendMMCommand(wnd:HWND; cmd:integer):integer; +begin +// result:=ord(SendMessageW(wnd,WM_APPCOMMAND,wnd,cmd shl 16)); + result:=ord(SendnotifyMessageW(wnd,WM_APPCOMMAND,wnd,cmd shl 16)); +end; + +end. diff --git a/delphi/Awkward/utils/base64.pas b/delphi/Awkward/utils/base64.pas new file mode 100644 index 0000000..73ce09b --- /dev/null +++ b/delphi/Awkward/utils/base64.pas @@ -0,0 +1,108 @@ +unit Base64; + +interface + +uses windows; + +{ Base64 encode and decode a string } +function BASE64Encode(src:pByte;len:integer):PAnsiChar; +function BASE64Decode(src:PAnsiChar;var dst:pByte):integer; + +{******************************************************************************} +{******************************************************************************} +implementation + +uses common; + +const + base64chars{:array [0..63] of AnsiChar}:PAnsiChar = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + +function BASE64Encode(src:pByte;len:integer):PAnsiChar; +var + dst:PAnsiChar; +begin + if (src=nil) or (len<=0) then + begin + result:=nil; + exit; + end; + mGetMem(result,((len*4+11) div (12*4))+1); + dst:=result; + + while len>0 do + begin + dst^:=base64chars[src^ shr 2]; inc(dst); + if len=1 then + begin + dst^:=base64chars[(src^ and 3) shl 4]; inc(dst); + dst^:='='; inc(dst); + dst^:='='; inc(dst); + break; + end; + dst^:=base64chars[((src^ and 3) shl 4) or (pbyte(PAnsiChar(src)+1)^ shr 4)]; inc(dst); inc(src); + if len=2 then + begin + dst^:=base64chars[(src^ and $F) shl 2]; inc(dst); + dst^:='='; inc(dst); + break; + end; + dst^:=base64chars[((src^ and $F) shl 2) or (pbyte(PAnsiChar(src)+1)^ shr 6)]; inc(dst); inc(src); + dst^:=base64chars[src^ and $3F]; inc(dst); inc(src); + dec(len,3); + end; + dst^:=#0; +end; + +function Base64CharToInt(c:AnsiChar):byte; +begin + case c of + 'A'..'Z': result:=ord(c)-ord('A'); + 'a'..'z': result:=ord(c)-ord('a')+26; + '0'..'9': result:=ord(c)-ord('0')+52; + '+': result:=62; + '/': result:=63; + '=': result:=64; + else + result:=255; + end; +end; + +function BASE64Decode(src:PAnsiChar;var dst:pByte):integer; +var + slen:integer; + ptr:pByte; + b1,b2,b3,b4:byte; +begin + if (src=nil) or (src^=#0) then + begin + result:=0; + dst:=nil; + exit; + end; + ptr:=pbyte(src); + while ptr^<>0 do inc(ptr); + slen:=ptr-src; + mGetMem(ptr,(slen*3) div 4); + dst:=ptr; + result:=0; + while slen>0 do + begin + b1:=Base64CharToInt(src^); inc(src); + b2:=Base64CharToInt(src^); inc(src); + b3:=Base64CharToInt(src^); inc(src); + b4:=Base64CharToInt(src^); inc(src); + dec(slen,4); + if (b1=255) or (b1=64) or (b2=255) or (b2=64) or (b3=255) or (b4=255) then + break; + ptr^:=(b1 shl 2) or (b2 shr 4); inc(ptr); inc(result); + if b3=64 then + break; + ptr^:=(b2 shl 4) or (b3 shr 2); inc(ptr); inc(result); + if b4=64 then + break; + ptr^:=b4 or (b3 shl 6); inc(ptr); inc(result); + end; +end; + +end. diff --git a/delphi/Awkward/utils/cbex.pas b/delphi/Awkward/utils/cbex.pas new file mode 100644 index 0000000..b4f94c6 --- /dev/null +++ b/delphi/Awkward/utils/cbex.pas @@ -0,0 +1,79 @@ +unit CBEx; +interface + +uses windows,commctrl; + +// build combobox with xstatus icons and names + +function AddCBEx(wnd:HWND;proto:PAnsiChar):HWND; + +implementation + +uses messages,m_api,kol,common,mirutils; + +function AddCBEx(wnd:HWND;proto:PAnsiChar):HWND; +var + cbei:TCOMBOBOXEXITEMW; + total,cnt:integer; + il:HIMAGELIST; + icon:HICON; + buf,buf1:array [0..127] of AnsiChar; + b:array [0..63] of WideChar; + ics:TICQ_CUSTOM_STATUS; +begin + result:=0; + SendMessage(wnd,CB_RESETCONTENT,0,0); + StrCopy(buf,proto); + StrCat (buf,PS_ICQ_GETCUSTOMSTATUSICON); + if PluginLink^.ServiceExists(buf)=0 then + exit; + + il:=ImageList_Create(16,16,ILC_COLOR32 or ILC_MASK,0,1); + if il=0 then exit; + + cnt:=0; + StrCopy(buf1,proto); + StrCat (buf1,PS_ICQ_GETCUSTOMSTATUSEX); + cbei.mask:=CBEIF_IMAGE or CBEIF_SELECTEDIMAGE or CBEIF_TEXT; //!! + ics.cbSize :=SizEOf(ics); + ics.flags :=CSSF_STATUSES_COUNT; + ics.szName.w:=@b; + ics.wParam :=@total; + CallService(buf1,0,dword(@ics)); + ics.flags :=CSSF_DEFAULT_NAME or CSSF_MASK_NAME or CSSF_UNICODE; + + while cnt<=total do + begin + if cnt=0 then + begin + ImageList_AddIcon(il,CallService(MS_SKIN_LOADICON,SKINICON_OTHER_SMALLDOT,0)); + cbei.pszText:=TranslateW('None'); + end + else + begin + icon:=CallService(buf,cnt,LR_SHARED); + if icon=0 then break; + if ImageList_AddIcon(il,icon)=-1 then break; + ics.wParam:=@cnt; + CallService(buf1,0,dword(@ics)); + cbei.pszText:=TranslateW(@b); + end; + cbei.iItem :=cnt; + cbei.iImage :=cnt; + cbei.iSelectedImage:=cnt; + if SendMessageW(wnd,CBEM_INSERTITEMW,0,dword(@cbei))=-1 then break; + inc(cnt); +// DestroyIcon(icon); + end; + + if cnt=0 then + ImageList_Destroy(il) + else + begin + ImageList_Destroy(SendMessage(wnd,CBEM_SETIMAGELIST,0,il)); + SendMessage(wnd,CB_SETCURSEL,0,0); + result:=wnd; + end; +end; + +end. \ No newline at end of file diff --git a/delphi/Awkward/utils/common.pas b/delphi/Awkward/utils/common.pas new file mode 100644 index 0000000..cdaabe3 --- /dev/null +++ b/delphi/Awkward/utils/common.pas @@ -0,0 +1,2116 @@ +{$DEFINE USE_MMI} +{$INCLUDE compilers.inc} +unit common; + +interface + +uses windows +{$IFDEF USE_MMI} +,m_api +{$ENDIF} +; + +Const {- Character sets -} + sBinNum = ['0'..'1']; + sOctNum = ['0'..'7']; + sNum = ['0'..'9']; + sHexNum = ['0'..'9','A'..'F','a'..'f']; + sWord = ['0'..'9','A'..'Z','a'..'z','_',#128..#255]; + sIdFirst = ['A'..'Z','a'..'z','_']; + sLatWord = ['0'..'9','A'..'Z','a'..'z','_']; + sWordOnly = ['A'..'Z','a'..'z']; + sSpace = [#9,' ']; + sEmpty = [#9,#10,#13,' ']; + +const + HexDigitChrLo: array [0..15] of AnsiChar = ('0','1','2','3','4','5','6','7', + '8','9','a','b','c','d','e','f'); + + HexDigitChr : array [0..15] of AnsiChar = ('0','1','2','3','4','5','6','7', + '8','9','A','B','C','D','E','F'); + +const + mimecnt = 5; + mimes:array [0..mimecnt-1] of record + mime:PAnsiChar; + ext:array [0..3] of AnsiChar + end = ( + (mime:'image/gif' ; ext:'GIF'), + (mime:'image/jpg' ; ext:'JPG'), + (mime:'image/jpeg'; ext:'JPG'), + (mime:'image/png' ; ext:'PNG'), + (mime:'image/bmp' ; ext:'BMP') +); + +var + IsW2K, + IsVista, + IsAnsi:boolean; + +const + CP_UNICODE = 1200; + CP_REVERSEBOM = 65534; +const + SIGN_UNICODE = $FEFF; + SIGN_REVERSEBOM = $FFFE; + SIGN_UTF8 = $BFBBEF; + +function GetTextFormat(Buffer:pByte;sz:cardinal):integer; + +function IIF(cond:bool;ret1,ret2:integer ):integer; overload; +function IIF(cond:bool;ret1,ret2:PAnsiChar):PAnsiChar; overload; +function IIF(cond:bool;ret1,ret2:pWideChar):pWideChar; overload; +function IIF(cond:bool;ret1,ret2:Extended ):Extended; overload; +function IIF(cond:bool;ret1,ret2:tDateTime):tDateTime; overload; +function IIF(cond:bool;ret1,ret2:pointer ):pointer; overload; +function IIF(cond:bool;ret1,ret2:string ):string; overload; +{$IFNDEF DELPHI7_UP} +function IIF(cond:bool;ret1,ret2:variant ):variant; overload; +{$ENDIF} + +function GetImageType (buf:pByte;mime:PAnsiChar=nil):dword; +function GetImageTypeW(buf:pByte;mime:PWideChar=nil):int64; + +procedure CopyToClipboard(txt:pointer; ansi:bool); +function PasteFromClipboard(ansi:boolean;cp:dword=CP_ACP):pointer; + +function mGetMem (var dst;size:integer):pointer; +procedure mFreeMem(var ptr); +function mReallocMem(var dst; size:integer):pointer; + +// String processing +function WideToCombo(src:PWideChar;var dst;cp:integer=CP_ACP):integer; + +function ChangeUnicode(str:PWideChar):PWideChar; +function UTF8Len(src:PAnsiChar):integer; +function WideToANSI(src:PWideChar;var dst:PAnsiChar;cp:dword=CP_ACP):PAnsiChar; +function ANSIToWide(src:PAnsiChar;var dst:PWideChar;cp:dword=CP_ACP):PWideChar; +function ANSIToUTF8(src:PAnsiChar;var dst:PAnsiChar;cp:dword=CP_ACP):PAnsiChar; +function UTF8toANSI(src:PAnsiChar;var dst:PAnsiChar;cp:dword=CP_ACP):PAnsiChar; +function UTF8toWide(src:PAnsiChar;var dst:PWideChar;len:cardinal=dword(-1)):PWideChar; +function WidetoUTF8(src:PWideChar;var dst:PAnsiChar):PAnsiChar; + +function FastWideToAnsiBuf(src:PWideChar;dst:PAnsiChar;len:cardinal=dword(-1)):PAnsiChar; +function FastAnsiToWideBuf(src:PAnsiChar;dst:PWideChar;len:cardinal=dword(-1)):PWideChar; +function FastWideToAnsi (src:PWideChar;var dst:PAnsiChar):PAnsiChar; +function FastAnsiToWide (src:PAnsiChar;var dst:PWideChar):PWideChar; + +function UnEscape(buf:PAnsiChar):PAnsiChar; +function Escape (buf:PAnsiChar):PAnsiChar; + +// ----- base strings functions ----- +function StrDup (var dst:PAnsiChar;src:PAnsiChar;len:cardinal=0):PAnsiChar; +function StrDupW(var dst:PWideChar;src:PWideChar;len:cardinal=0):PWideChar; +function StrDelete (aStr:PAnsiChar;pos,len:cardinal):PAnsiChar; +function StrDeleteW(aStr:PWideChar;pos,len:cardinal):PWideChar; +function StrInsert (substr,src:PAnsiChar;pos:cardinal):PAnsiChar; +function StrInsertW(substr,src:PWideChar;pos:cardinal):PWideChar; +function StrReplace (src,SubStr,NewStr:PAnsiChar):PAnsiChar; +function StrReplaceW(src,SubStr,NewStr:pWideChar):PWideChar; +function CharReplace (dst:pAnsiChar;old,new:AnsiChar):PAnsiChar; +function CharReplaceW(dst:pWideChar;old,new:WideChar):PWideChar; +function StrCmp (a,b:PAnsiChar;n:cardinal=$FFFFFFFF):integer; +function StrCmpW(a,b:PWideChar;n:cardinal=$FFFFFFFF):integer; +function StrEnd (const a:PAnsiChar):PAnsiChar; +function StrEndW(const a:PWideChar):PWideChar; +function StrScan (src:PAnsiChar;c:AnsiChar):PAnsiChar; +function StrScanW(src:PWideChar;c:WideChar):PWideChar; +function StrRScan (src:PAnsiChar;c:AnsiChar):PAnsiChar; +function StrRScanW(src:PWideChar;c:WideChar):PWideChar; +function StrLen (Str: PAnsiChar): Cardinal; +function StrLenW(Str: PWideChar): Cardinal; +function StrCat (Dest: PAnsiChar; const Source: PAnsiChar): PAnsiChar; +function StrCatW(Dest: PWideChar; const Source: PWideChar): PWideChar; +function StrCopyE (dst:PAnsiChar;src:PAnsiChar;len:cardinal=0):PAnsiChar; +function StrCopyEW(dst:PWideChar;src:PWideChar;len:cardinal=0):PWideChar; +function StrCopy (dst:PAnsiChar;src:PAnsiChar;len:cardinal=0):PAnsiChar; +function StrCopyW(dst:PWideChar;src:PWideChar;len:cardinal=0):PWideChar; +function StrPos (const aStr, aSubStr: PAnsiChar): PAnsiChar; +function StrPosW(const aStr, aSubStr: PWideChar): PWideChar; +function StrIndex (const aStr, aSubStr: PAnsiChar):integer; +function StrIndexW(const aStr, aSubStr: PWideChar):integer; + +//procedure FillWord(var buf;count:cardinal;value:word); register; +function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; +function Min(a,b:integer):integer; +function Max(a,b:integer):integer; + +function Timestamp(Year,Month,Day:cardinal;Hour:cardinal=0;Min:cardinal=0;Sec:cardinal=0):dword; +function GetCurrentTime:dword; + +function TimeToInt(stime:PAnsiChar):integer; overload; +function TimeToInt(stime:PWideChar):integer; overload; +function IntToTime(dst:pWideChar;time:integer):pWideChar; overload; +function IntToTime(dst:PAnsiChar;time:integer):PAnsiChar; overload; + +{ + filesize to string conversion + value - filelength + divider - 1=byte; 1024=kbyte; 1024*1024 - Mbyte + prec - numbers after point (1-3) + post - 0=none + 1=(small)' bytes','kb','mb' + 2=(mix) ' Bytes','Kb','Mb' + 3=(caps) '' ,'KB','MB' + postfix calculated from 'divider' value +} +function IntToK(dst:pWideChar;value,divider,prec,post:integer):pWideChar; + +// string conversion +function IntToHex(dst:pWideChar;Value:dword ;Digits:integer=0):pWideChar; overload; +function IntToHex(dst:PAnsiChar;Value:dword ;Digits:integer=0):PAnsiChar; overload; +function IntToStr(dst:pWideChar;Value:integer;Digits:integer=0):pWideChar; overload; +function IntToStr(dst:PAnsiChar;Value:integer;Digits:integer=0):PAnsiChar; overload; +function StrToInt(src:pWideChar):integer; overload; +function StrToInt(src:PAnsiChar):integer; overload; +function HexToInt(src:pWideChar):integer; overload; +function HexToInt(src:PAnsiChar):integer; overload; + +// filename work +function ChangeExt (src,ext:PAnsiChar):PAnsiChar; +function ChangeExtW(src,ext:PWideChar):PWideChar; +function Extract (s:PAnsiChar;name:Boolean=true):PAnsiChar; +function ExtractW(s:pWideChar;name:Boolean=true):pWideChar; +function GetExt(fname,dst:pWideChar;maxlen:dword=100):pWideChar; overload; +function GetExt(fname,dst:PAnsiChar;maxlen:dword=100):PAnsiChar; overload; + +procedure UpperCase(src:pWideChar); +procedure LowerCase(src:pWideChar); +function GetPairChar(ch:AnsiChar):AnsiChar; overload; +function GetPairChar(ch:WideChar):WideChar; overload; + +type + lSortProc = function (First,Second:integer):integer; + {0=equ; 1=1st>2nd; -1=1st<2nd } +procedure ShellSort(size:integer;Compare,Swap:lSortProc); + +function isPathAbsolute(path:pWideChar):boolean; overload; +function isPathAbsolute(path:PAnsiChar):boolean; overload; + +implementation + +const + IS_TEXT_UNICODE_ASCII16 = $1; + IS_TEXT_UNICODE_REVERSE_ASCII16 = $10; + IS_TEXT_UNICODE_STATISTICS = $2; + IS_TEXT_UNICODE_REVERSE_STATISTICS = $20; + IS_TEXT_UNICODE_CONTROLS = $4; + IS_TEXT_UNICODE_REVERSE_CONTROLS = $40; + IS_TEXT_UNICODE_SIGNATURE = $8; + IS_TEXT_UNICODE_REVERSE_SIGNATURE = $80; + IS_TEXT_UNICODE_ILLEGAL_CHARS = $100; + IS_TEXT_UNICODE_ODD_LENGTH = $200; + IS_TEXT_UNICODE_DBCS_LEADBYTE = $400; + IS_TEXT_UNICODE_NULL_BYTES = $1000; + IS_TEXT_UNICODE_UNICODE_MASK = $F; + IS_TEXT_UNICODE_REVERSE_MASK = $F0; + IS_TEXT_UNICODE_NOT_UNICODE_MASK = $F00; + IS_TEXT_UNICODE_NOT_ASCII_MASK = $F000; + +function IsTextUTF8(Buffer:pbyte;Length:integer):boolean; +var + Ascii:boolean; + Octets:cardinal; + c:byte; +begin + Ascii:=true; + Octets:=0; + + if Length=0 then + Length:=-1; + repeat + if (Length=0) or (Buffer^=0) then + break; + dec(Length); + c:=Buffer^; + if (c and $80)<>0 then + Ascii:=false; + if Octets<>0 then + begin + if (c and $C0)<>$80 then + begin + result:=false; + exit; + end; + dec(Octets); + end + else + begin + if (c and $80)<>0 then + begin + while (c and $80)<>0 do + begin + c:=c shl 1; + inc(Octets); + end; + dec(Octets); + if Octets=0 then + begin + result:=false; + exit; + end; + end + end; + inc(buffer); + until false; + result:= not ((Octets>0) or Ascii); +end; + +function GetTextFormat(Buffer:pByte;sz:cardinal):integer; +var + test:integer; +begin + result:=-1; + + if sz>=2 then + begin + if pword (Buffer)^ =SIGN_UNICODE then result := CP_UNICODE + else if pword (Buffer)^ =SIGN_REVERSEBOM then result := CP_REVERSEBOM + else if (sz>=4) and + ((pdword(Buffer)^ and $00FFFFFF)=SIGN_UTF8) then result := CP_UTF8; + end; + + if result<0 then + begin + test:= + IS_TEXT_UNICODE_STATISTICS or + IS_TEXT_UNICODE_REVERSE_STATISTICS or + IS_TEXT_UNICODE_CONTROLS or + IS_TEXT_UNICODE_REVERSE_CONTROLS or + IS_TEXT_UNICODE_ILLEGAL_CHARS or + IS_TEXT_UNICODE_ODD_LENGTH or + IS_TEXT_UNICODE_NULL_BYTES; + + if not odd(sz) and IsTextUnicode(Buffer,sz,@test) then + begin + if (test and (IS_TEXT_UNICODE_ODD_LENGTH or IS_TEXT_UNICODE_ILLEGAL_CHARS))=0 then + begin + if (test and (IS_TEXT_UNICODE_NULL_BYTES or + IS_TEXT_UNICODE_CONTROLS or + IS_TEXT_UNICODE_REVERSE_CONTROLS))<>0 then + begin + if (test and (IS_TEXT_UNICODE_CONTROLS or + IS_TEXT_UNICODE_STATISTICS))<>0 then + result:=CP_UNICODE + else if (test and (IS_TEXT_UNICODE_REVERSE_CONTROLS or + IS_TEXT_UNICODE_REVERSE_STATISTICS))<>0 then + result:=CP_REVERSEBOM; + end + end + end + else if IsTextUTF8(Buffer,sz) then + result:=CP_UTF8 + else + result:=CP_ACP; + end; +end; + +function IIF(cond:bool;ret1,ret2:integer):integer; overload; +begin + if cond then result:=ret1 else result:=ret2; +end; +function IIF(cond:bool;ret1,ret2:PAnsiChar):PAnsiChar; overload; +begin + if cond then result:=ret1 else result:=ret2; +end; +function IIF(cond:bool;ret1,ret2:pWideChar):pWideChar; overload; +begin + if cond then result:=ret1 else result:=ret2; +end; +function IIF(cond:bool;ret1,ret2:Extended):Extended; overload; +begin + if cond then result:=ret1 else result:=ret2; +end; +function IIF(cond:bool;ret1,ret2:tDateTime):tDateTime; overload; +begin + if cond then result:=ret1 else result:=ret2; +end; +function IIF(cond:bool;ret1,ret2:pointer):pointer; overload; +begin + if cond then result:=ret1 else result:=ret2; +end; +function IIF(cond:bool;ret1,ret2:string):string; overload; +begin + if cond then result:=ret1 else result:=ret2; +end; +{$IFNDEF DELPHI7_UP} +function IIF(cond:bool;ret1,ret2:variant):variant; overload; +begin + if cond then result:=ret1 else result:=ret2; +end; +{$ENDIF} + +function GetImageType(buf:pByte;mime:PAnsiChar=nil):dword; +var + i:integer; +begin + result:=0; + if (mime<>nil) and (mime^<>#0) then + begin + for i:=0 to mimecnt-1 do + begin + if {lstrcmpia}StrCmp(mime,mimes[i].mime)=0 then + begin + result:=dword(mimes[i].ext); + exit; + end; + end; + end + else if buf<>nil then + begin + if (pdword(buf)^ and $F0FFFFFF)=$E0FFD8FF then result:=$0047504A // 'JPG' + else if pdword(buf)^=$38464947 then result:=$00464947 // 'GIF' + else if pdword(buf)^=$474E5089 then result:=$00474E50 // 'PNG' + else if pword (buf)^=$4D42 then result:=$00504D42 // 'BMP' + end; +end; + +function GetImageTypeW(buf:pByte;mime:PWideChar=nil):int64; +var + i:integer; + lmime:array [0..63] of AnsiChar; +begin + result:=0; + if (mime<>nil) and (mime^<>#0) then + begin + FastWideToAnsiBuf(mime,lmime); + for i:=0 to mimecnt-1 do + begin + if {lstrcmpia}StrCmp(lmime,mimes[i].mime)=0 then + begin +// result:=dword(mimes[i].ext); + FastAnsiToWideBuf(mimes[i].ext,PWideChar(@result)); + exit; + end; + end; + end + else if buf<>nil then + begin + if (pdword(buf)^ and $F0FFFFFF)=$E0FFD8FF then result:=$000000470050004A // 'JPG' + else if pdword(buf)^=$38464947 then result:=$0000004600490047 // 'GIF' + else if pdword(buf)^=$474E5089 then result:=$00000047004E0050 // 'PNG' + else if pword (buf)^=$4D42 then result:=$00000050004D0042 // 'BMP' + end; +end; + +procedure CopyToClipboard(txt:pointer; ansi:bool); +var + s:pointer; + fh:THANDLE; +begin + if pointer(txt)=nil then + exit; + if ansi then + begin + if PAnsiChar(txt)^=#0 then exit + end + else + if PWideChar(txt)^=#0 then exit; + + if OpenClipboard(0) then + begin + if ansi then + begin + fh:=GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE,(StrLen(PAnsiChar(txt))+1)); + s:=GlobalLock(fh); + StrCopy(s,PAnsiChar(txt)); + end + else + begin + fh:=GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, + (StrLenW(PWideChar(txt))+1)*SizeOf(WideChar)); + s:=GlobalLock(fh); + StrCopyW(s,PWideChar(txt)); + end; + GlobalUnlock(fh); + EmptyClipboard; + if ansi then + SetClipboardData(CF_TEXT,fh) + else + SetClipboardData(CF_UNICODETEXT,fh); + GlobalFree(fh); + CloseClipboard; + end; +end; + +function PasteFromClipboard(ansi:boolean;cp:dword=CP_ACP):pointer; +var + p:pWideChar; + fh:tHandle; +begin + if OpenClipboard(0) then + begin + if not ansi then + begin + fh:=GetClipboardData(CF_UNICODETEXT); + if fh<>0 then + begin + p:=GlobalLock(fh); + StrDupW(pWideChar(result),p); + end + else + begin + fh:=GetClipboardData(CF_TEXT); + if fh<>0 then + begin + p:=GlobalLock(fh); + AnsiToWide(PAnsiChar(p),pWideChar(result),cp); + end; + end; + end + else + begin + fh:=GetClipboardData(CF_TEXT); + if fh<>0 then + begin + p:=GlobalLock(fh); + StrDup(PAnsiChar(result),PAnsiChar(p)); + end; + end; + if fh<>0 then + GlobalUnlock(fh); + CloseClipboard; + end +end; + +procedure CheckSystem; +var + ovi:TOSVersionInfo; +begin + ovi.dwOSVersionInfoSize:=SizeOf(TOSVersionInfo); + GetVersionEx(ovi); +//VER_PLATFORM_WIN32_NT for 2KXP + with ovi do + begin + IsAnsi :=dwPlatformId=VER_PLATFORM_WIN32_WINDOWS; + IsW2K :=(dwMajorVersion=5) and (dwMinorVersion=0); + IsVista:=(dwMajorVersion=6) and (dwMinorVersion=0); + end; +end; + +// --------- string conversion ---------- + +function WideToCombo(src:PWideChar;var dst;cp:integer=CP_ACP):integer; +var + pc:PAnsiChar; + i,j:Cardinal; +begin + WideToAnsi(src,pc,cp); + j:=StrLen(pc)+1; + i:=j+(StrLenW(src)+1)*SizeOf(WideChar); + mGetMem(PAnsiChar(dst),i); + StrCopy(PAnsiChar(dst),pc); + mFreeMem(pc); + StrCopyW(pWideChar(PAnsiChar(dst)+j),src); + result:=i; +end; + +function ChangeUnicode(str:PWideChar):PWideChar; +var + i,len:integer; +begin + result:=str; + if (str=nil) or (str^=#0) then + exit; + if (word(str^)=$FFFE) or (word(str^)=$FEFF) then + begin + len:=StrLenW(str); + if word(str^)=$FFFE then + begin + i:=len-1; + while i>0 do // str^<>#0 + begin + pword(str)^:=swap(pword(str)^); + inc(str); + dec(i); + end; + end; + move((result+1)^,result^,len*SizeOf(WideChar)); + end; +end; + +function WideToANSI(src:PWideChar;var dst:PAnsiChar; cp:dword=CP_ACP):PAnsiChar; +var + len,l:integer; +begin + if (src=nil) or (src^=#0) then + begin + mGetMem(result,SizeOf(AnsiChar)); + result^:=#0; + end + else + begin + l:=StrLenW(src); + len:=WideCharToMultiByte(cp,0,src,l,NIL,0,NIL,NIL)+1; + mGetMem(result,len); + FillChar(result^,len,0); + WideCharToMultiByte(cp,0,src,l,result,len,NIL,NIL); + end; + dst:=result; +end; + +function ANSIToWide(src:PAnsiChar;var dst:PWideChar; cp:dword=CP_ACP):PWideChar; +var + len,l:integer; +begin + if (src=nil) or (src^=#0) then + begin + mGetMem(result,SizeOf(WideChar)); + result^:=#0; + end + else + begin + l:=StrLen(src); + len:=MultiByteToWideChar(cp,0,src,l,NIL,0)+1; + mGetMem(result,len*SizeOf(WideChar)); + FillChar(result^,len*SizeOf(WideChar),0); + MultiByteToWideChar(cp,0,src,l,result,len); + end; + dst:=result; +end; + +function ANSIToUTF8(src:PAnsiChar;var dst:PAnsiChar;cp:dword=CP_ACP):PAnsiChar; +var + tmp:PWideChar; +begin + AnsiToWide(src,tmp,cp); + result:=WideToUTF8(tmp,dst); + mFreeMem(tmp); +end; + +function UTF8Len(src:PAnsiChar):integer; // w/o zero +begin + result:=0; + if src<>nil then + begin + if (pdword(src)^ and $00FFFFFF)=SIGN_UTF8 then + inc(src,3); + while src^<>#0 do + begin + if (ord(src^) and $80)=0 then + else if (ord(src^) and $E0)=$E0 then + inc(src,2) + else + inc(src); + inc(result); + inc(src); + end; + end; +end; + +function CalcUTF8Len(src:pWideChar):integer; +begin + result:=0; + if src<>nil then + begin + while src^<>#0 do + begin + if src^<#$0080 then + else if src^<#$0800 then + inc(result) + else + inc(result,2); + inc(src); + inc(result); + end; + end; +end; + +function UTF8toWide(src:PAnsiChar; var dst:PWideChar; len:cardinal=dword(-1)):PWideChar; +var + w:word; + p:PWideChar; +begin + mGetMem(dst,(UTF8Len(src)+1)*SizeOf(WideChar)); + p:=dst; + if src<>nil then + begin + if (pdword(src)^ and $00FFFFFF)=SIGN_UTF8 then + inc(src,3); + while (src^<>#0) and (len>0) do + begin + if ord(src^)<$80 then + w:=ord(src^) + else if (ord(src^) and $E0)=$E0 then + begin + w:=(ord(src^) and $1F) shl 12; + inc(src); dec(len); + w:=w or (((ord(src^))and $3F) shl 6); + inc(src); dec(len); + w:=w or (ord(src^) and $3F); + end + else + begin + w:=(ord(src^) and $3F) shl 6; + inc(src); dec(len); + w:=w or (ord(src^) and $3F); + end; + p^:=WideChar(w); + inc(p); + inc(src); dec(len); + end; + end; + p^:=#0; + result:=dst; +end; + +function UTF8toANSI(src:PAnsiChar;var dst:PAnsiChar;cp:dword=CP_ACP):PAnsiChar; +var + tmp:pWideChar; +begin + UTF8ToWide(src,tmp); + result:=WideToAnsi(tmp,dst,cp); + mFreeMem(tmp); +end; + +function WidetoUTF8(src:PWideChar; var dst:PAnsiChar):PAnsiChar; +var + p:PAnsiChar; +begin + mGetMem(dst,CalcUTF8Len(src)+1); + p:=dst; + if src<>nil then + begin + while src^<>#0 do + begin + if src^<#$0080 then + p^:=AnsiChar(src^) + else if src^<#$0800 then + begin + p^:=AnsiChar($C0 or (ord(src^) shr 6)); + inc(p); + p^:=AnsiChar($80 or (ord(src^) and $3F)); + end + else + begin + p^:=AnsiChar($E0 or (ord(src^) shr 12)); + inc(p); + p^:=AnsiChar($80 or ((ord(src^) shr 6) and $3F)); + inc(p); + p^:=AnsiChar($80 or (ord(src^) and $3F)); + end; + inc(p); + inc(src); + end; + end; + p^:=#0; + result:=dst; +end; + +procedure FillWord(var buf;count:cardinal;value:word); register; assembler; +{ + PUSH EDI + MOV EDI, ECX // Move Value To Write + MOV ECX, EDX // Move Number to ECX for countdown + MOV EDX, EAX // Move over buffer + MOV EAX, EDI // Value to Write needs to be here + MOV EDI, EDX // Pointer to Buffer[0] + REP STOSW + POP EDI +} +asm + push edi + mov edi,eax // destination + mov ax,cx // value + mov ecx,edx // count + rep stosw + pop edi +end; + +// from SysUtils +{ Delphi 7.0 +function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; +asm + PUSH ESI + PUSH EDI + MOV ESI,P1 + MOV EDI,P2 + MOV EDX,ECX + XOR EAX,EAX + AND EDX,3 + SAR ECX,2 + JS @@1 // Negative Length implies identity. + REPE CMPSD + JNE @@2 + MOV ECX,EDX + REPE CMPSB + JNE @@2 +@@1: INC EAX +@@2: POP EDI + POP ESI +end; +} +// Delphi 2009 realization +function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; +asm + add eax, ecx + add edx, ecx + xor ecx, -1 + add eax, -8 + add edx, -8 + add ecx, 9 + push ebx + jg @Dword + mov ebx, [eax+ecx] + cmp ebx, [edx+ecx] + jne @Ret0 + lea ebx, [eax+ecx] + add ecx, 4 + and ebx, 3 + sub ecx, ebx + jg @Dword +@DwordLoop: + mov ebx, [eax+ecx] + cmp ebx, [edx+ecx] + jne @Ret0 + mov ebx, [eax+ecx+4] + cmp ebx, [edx+ecx+4] + jne @Ret0 + add ecx, 8 + jg @Dword + mov ebx, [eax+ecx] + cmp ebx, [edx+ecx] + jne @Ret0 + mov ebx, [eax+ecx+4] + cmp ebx, [edx+ecx+4] + jne @Ret0 + add ecx, 8 + jle @DwordLoop +@Dword: + cmp ecx, 4 + jg @Word + mov ebx, [eax+ecx] + cmp ebx, [edx+ecx] + jne @Ret0 + add ecx, 4 +@Word: + cmp ecx, 6 + jg @Byte + movzx ebx, word ptr [eax+ecx] + cmp bx, [edx+ecx] + jne @Ret0 + add ecx, 2 +@Byte: + cmp ecx, 7 + jg @Ret1 + movzx ebx, byte ptr [eax+7] + cmp bl, [edx+7] + jne @Ret0 +@Ret1: + mov eax, 1 + pop ebx + ret +@Ret0: + xor eax, eax + pop ebx +end; + +function Min(a,b:integer):integer; +begin + if a>b then + result:=b + else + result:=a; +end; + +function Max(a,b:integer):integer; +begin + if anil then + pointer(dst):=mmi.malloc(size) + else +{$ENDIF} + GetMem(pointer(dst),size); + result:=pointer(dst); +end; + +procedure mFreeMem(var ptr); +begin + if pointer(ptr)<>nil then + begin +{$IFDEF USE_MMI} + if @mmi.free<>nil then + mmi.free(pointer(ptr)) + else +{$ENDIF} + FreeMem(pointer(ptr)); + Pointer(ptr):=nil; + end; +end; + +function mReallocMem(var dst; size:integer):pointer; +begin +{$IFDEF USE_MMI} + if @mmi.malloc<>nil then + pointer(dst):=mmi.realloc(pointer(dst),size) + else +{$ENDIF} + ReallocMem(pointer(dst),size); + result:=pointer(dst); +end; + +function UnEscape(buf:PAnsiChar):PAnsiChar; +begin + if (buf<>nil) and (buf^<>#0) then + begin + StrReplace(buf,PAnsiChar(#$7F'n'),PAnsiChar(#$0D#$0A)); + StrReplace(buf,PAnsiChar(#$7F't'),PAnsiChar(#$09)); + end; + result:=buf; +end; + +function Escape(buf:PAnsiChar):PAnsiChar; +var + i:integer; +begin + i:=StrLen(buf); + if i<>0 then + begin + Move(buf^,(buf+1)^,i+1); + buf^:=#39; + (buf+i+1)^:=#39; + (buf+i+2)^:=#0; + StrReplace(buf,#$0D#$0A,#$7F'n'); + StrReplace(buf,#$09,#$7F't'); + end; + result:=buf; +end; + +procedure ShellSort(size:integer;Compare,Swap:lSortProc); +var + i,j,gap:longint; +begin + gap:=size shr 1; + while gap>0 do + begin + for i:=gap to size-1 do + begin + j:=i-gap; + while (j>=0) and (Compare(j,UInt(j+gap))>0) do + begin + Swap(j,UInt(j+gap)); + dec(j,gap); + end; + end; + gap:=gap shr 1; + end; +end; + +const + Posts:array [0..8] of PWideChar = + (' bytes',' Bytes','','kb','Kb','KB','mb','Mb','MB'); + +function IntToK(dst:pWidechar;value,divider,prec,post:integer):pWidechar; +var + tmp:integer; + p:pWideChar; + ls:array [0..4] of WideChar; +begin + result:=dst; + IntToStr(dst,value div divider); + if divider=1 then prec:=0; + while dst^<>#0 do inc(dst); + if prec<>0 then + begin + if prec=1 then prec:=10 + else if prec=2 then prec:=100 + else {if prec=3 then} prec:=1000; + tmp:=round(frac(value*1.0/divider)*prec); + dst^:='.'; inc(dst); + IntToStr(ls,tmp); + p:=ls; + while p^<>#0 do + begin + dst^:=p^; inc(dst); inc(p); + end; + dst^:=#0; + end; + if post<>0 then + begin + if divider=1 then + StrCatW(dst,Posts[post-1]) + else + begin + if divider=1024 then tmp:=1 + else {if divider=1024*1024 then} tmp:=2; + p:=Posts[tmp*3+post-1]; + dst^:=p[0]; inc(dst); + dst^:=p[1]; inc(dst); + dst^:=#0; + end; + end; +end; + +// ----- base string functions ----- +function StrDup(var dst:PAnsiChar;src:PAnsiChar;len:cardinal=0):PAnsiChar; +var + l:cardinal; + p:pAnsiChar; +begin + if (src=nil) or (src^=#0) then + dst:=nil + else + begin + if len=0 then + len:=high(cardinal); + p:=src; + l:=len; + while (p^<>#0) and (l>0) do + begin + inc(p); dec(l); + end; + l:=p-src; + + mGetMem(dst,l+1); + move(src^, dst^,l); + dst[l]:=#0; + end; + result:=dst; +end; + +function StrDupW(var dst:PWideChar;src:PWideChar;len:cardinal=0):PWideChar; +var + l:cardinal; + p:pWideChar; +begin + if (src=nil) or (src^=#0) then + dst:=nil + else + begin + if len=0 then + len:=high(cardinal); + p:=src; + l:=len; + while (p^<>#0) and (l>0) do + begin + inc(p); dec(l); + end; + l:=p-src; + mGetMem(dst,(l+1)*SizeOf(WideChar)); + move(src^, dst^,l*SizeOf(WideChar)); + dst[l]:=#0; + end; + result:=dst; +end; + +function StrCopyE(dst:PAnsiChar;src:PAnsiChar;len:cardinal=0):PAnsiChar; +var + l:cardinal; + p:pAnsiChar; +begin + if dst<>nil then + begin + if (src=nil) or (src^=#0) then + dst^:=#0 + else + begin + if len=0 then + len:=high(cardinal); + p:=src; + l:=len; + while (p^<>#0) and (l>0) do + begin + inc(p); dec(l); + end; + l:=p-src; + move(src^, dst^,l); + inc(dst,l); + dst^:=#0; + end; + end; + result:=dst; +end; + +function StrCopyEW(dst:PWideChar;src:PWideChar;len:cardinal=0):PWideChar; +var + l:cardinal; + p:pWideChar; +begin + if dst<>nil then + begin + if (src=nil) or (src^=#0) then + dst^:=#0 + else + begin + if len=0 then + len:=high(cardinal); + p:=src; + l:=len; + while (p^<>#0) and (l>0) do + begin + inc(p); dec(l); + end; + l:=p-src; + move(src^, dst^,l*SizeOf(WideChar)); + inc(dst,l); + dst^:=#0; + end; + end; + result:=dst; +end; + +function StrCopy(dst:PAnsiChar;src:PAnsiChar;len:cardinal=0):PAnsiChar; +var + l:cardinal; + p:pAnsiChar; +begin + if dst<>nil then + begin + if (src=nil) or (src^=#0) then + dst^:=#0 + else + begin + if len=0 then + len:=high(cardinal); + p:=src; + l:=len; + while (p^<>#0) and (l>0) do + begin + inc(p); dec(l); + end; + l:=p-src; + move(src^, dst^,l); + dst[l]:=#0; + end; + end; + result:=dst; +end; + +function StrCopyW(dst:PWideChar;src:PWideChar;len:cardinal=0):PWideChar; +var + l:cardinal; + p:pWideChar; +begin + if dst<>nil then + begin + if (src=nil) or (src^=#0) then + dst^:=#0 + else + begin + if len=0 then + len:=high(cardinal); + p:=src; + l:=len; + while (p^<>#0) and (l>0) do + begin + inc(p); dec(l); + end; + l:=p-src; + move(src^, dst^,l*SizeOf(WideChar)); + dst[l]:=#0; + end; + end; + result:=dst; +end; + +function StrDelete(aStr:PAnsiChar;pos,len:cardinal):PAnsiChar; +var + i:cardinal; +begin + if len>0 then + begin + i:=StrLen(aStr); + if posi then + len:=i-pos; + StrCopy(aStr+pos,aStr+pos+len); + end; + end; + result:=aStr; +end; + +function StrDeleteW(aStr:PWideChar;pos,len:cardinal):PWideChar; +var + i:cardinal; +begin + if len>0 then + begin + i:=StrLenW(aStr); + if posi then + len:=i-pos; + StrCopyW(aStr+pos,aStr+pos+len); + end; + end; + result:=aStr; +end; + +function StrInsert(substr,src:PAnsiChar;pos:cardinal):PAnsiChar; +var + i:cardinal; + p:PAnsiChar; +begin + i:=StrLen(substr); + if i<>0 then + begin + p:=src+pos; + move(p^,(p+i)^,StrLen(src)-pos+1); + move(substr^,p^,i); + end; + result:=src; +end; + +function StrInsertW(substr,src:PWideChar;pos:cardinal):PWideChar; +var + i:cardinal; + p:PWideChar; +begin + i:=StrLenW(substr); + if i<>0 then + begin + p:=src+pos; + move(p^,(p+i)^,(StrLenW(src)-pos+1)*SizeOf(PWideChar)); + move(substr^,p^,i*SizeOf(WideChar)); + end; + result:=src; +end; + +function StrReplace(src,SubStr,NewStr:PAnsiChar):PAnsiChar; +var + i,j,l:integer; + k:integer; + p:PAnsiChar; +begin + result:=src; + p:=StrPos(src,SubStr); + if p=nil then exit; + i:=StrLen(SubStr); + j:=StrLen(NewStr); + l:=i-j; + repeat + if j=0 then + StrCopy(p,p+i) + else + begin + k:=StrLen(p)+1; + if l>0 then + move((p+l)^,p^,k-l) + else if l<>0 then + move(p^,(p-l)^,k); + move(NewStr^,p^,j); {new characters} + inc(p,j); + end; + p:=StrPos(p,SubStr); + if p=nil then break; + until false; +end; + +function StrReplaceW(src,SubStr,NewStr:pWideChar):PWideChar; +var + i,j,l:integer; + k:integer; + p:PWideChar; +begin + result:=src; + p:=StrPosW(src,SubStr); + if p=nil then exit; + i:=StrLenW(SubStr); + j:=StrLenW(NewStr); + l:=i-j; + repeat + if j=0 then + StrCopyW(p,p+i) + else + begin + k:=(StrLenW(p)+1)*SizeOf(WideChar); + if l>0 then + move((p+l)^,p^,k-l*SizeOf(WideChar)) + else if l<>0 then + move(p^,(p-l)^,k); + move(NewStr^,p^,j*SizeOf(WideChar)); {new characters} + inc(p,j); + end; + p:=StrPosW(p,SubStr); + if p=nil then break; + until false; +end; + +function CharReplace(dst:pAnsiChar;old,new:AnsiChar):PAnsiChar; +begin + result:=dst; + if dst<>nil then + begin + while dst^<>#0 do + begin + if dst^=old then dst^:=new; + inc(dst); + end; + end; +end; + +function CharReplaceW(dst:pWideChar;old,new:WideChar):PWideChar; +begin + result:=dst; + if dst<>nil then + begin + while dst^<>#0 do + begin + if dst^=old then dst^:=new; + inc(dst); + end; + end; +end; + +function StrCmp(a,b:PAnsiChar;n:cardinal=$FFFFFFFF):integer; // CompareString +begin + result:=0; + if (a=nil) and (b=nil) then + exit; + if (a=nil) or (b=nil) then + begin + result:=-1; + exit; + end; + while n>0 do + begin + result:=ord(a^)-ord(b^); + if (result<>0) or (a^=#0) then + break; + inc(a); + inc(b); + dec(n); + end; +end; + +function StrCmpW(a,b:PWideChar;n:cardinal=$FFFFFFFF):integer; +begin + result:=0; + if (a=nil) and (b=nil) then + exit; + if (a=nil) or (b=nil) then + begin + result:=-1; + exit; + end; + while n>0 do + begin + result:=ord(a^)-ord(b^); + if (result<>0) or (a^=#0) then + break; + inc(a); + inc(b); + dec(n); + end; +end; + +function StrEnd(const a:PAnsiChar):PAnsiChar; +begin + result:=a; + if result<>nil then + while result^<>#0 do inc(result); +end; + +function StrEndW(const a:PWideChar):PWideChar; +begin + result:=a; + if result<>nil then + while result^<>#0 do inc(result); +end; + +function StrScan(src:PAnsiChar;c:AnsiChar):PAnsiChar; +begin + if src<>nil then + begin + while (src^<>#0) and (src^<>c) do inc(src); + if src^<>#0 then + begin + result:=src; + exit; + end; + end; + result:=nil; +end; + +function StrRScan(src:PAnsiChar;c:AnsiChar):PAnsiChar; +begin + if src<>nil then + begin + result:=StrEnd(src); + while (result>=src) and (result^<>c) do dec(result); + if resultnil then + begin + while (src^<>#0) and (src^<>c) do inc(src); + if src^<>#0 then + begin + result:=src; + exit; + end; + end; + result:=nil; +end; + +function StrRScanW(src:PWideChar;c:WideChar):PWideChar; +begin + if src<>nil then + begin + result:=StrEndW(src); + while (result>=src) and (result^<>c) do dec(result); + if resultnil then + while (P^ <> #0) do Inc(P); + Result := (P - Str); +end; + +function StrLenW(Str: PWideChar): Cardinal; +var + P : PWideChar; +begin + P := Str; + if P<>nil then + while (P^ <> #0) do Inc(P); + Result := (P - Str); +end; + +function StrCat(Dest: PAnsiChar; const Source: PAnsiChar): PAnsiChar; +begin + if dest<>nil then + StrCopy(StrEnd(Dest), Source); + Result := Dest; +end; + +function StrCatW(Dest: PWideChar; const Source: PWideChar): PWideChar; +begin + if dest<>nil then + StrCopyW(StrEndW(Dest), Source); + Result := Dest; +end; + +function StrPos(const aStr, aSubStr: PAnsiChar): PAnsiChar; +var + Str, SubStr: PAnsiChar; + Ch: AnsiChar; +begin + if (aStr = nil) or (aStr^ = #0) or (aSubStr = nil) or (aSubStr^ = #0) then + begin + Result := nil; + Exit; + end; + Result := aStr; + Ch := aSubStr^; + repeat + if Result^ = Ch then + begin + Str := Result; + SubStr := aSubStr; + repeat + Inc(Str); + Inc(SubStr); + if SubStr^ = #0 then exit; + if Str^ = #0 then + begin + Result := nil; + exit; + end; + if Str^ <> SubStr^ then break; + until (FALSE); + end; + Inc(Result); + until (Result^ = #0); + Result := nil; +end; + +function StrIndex(const aStr, aSubStr: PAnsiChar):integer; +var + p:pAnsiChar; +begin + p:=StrPos(aStr,aSubStr); + if p=nil then + result:=0 + else + result:=p-aStr+1; +end; + +function StrPosW(const aStr, aSubStr: PWideChar): PWideChar; +var + Str, SubStr: PWideChar; + Ch: WideChar; +begin + if (aStr = nil) or (aStr^ = #0) or (aSubStr = nil) or (aSubStr^ = #0) then + begin + Result := nil; + Exit; + end; + Result := aStr; + Ch := aSubStr^; + repeat + if Result^ = Ch then + begin + Str := Result; + SubStr := aSubStr; + repeat + Inc(Str); + Inc(SubStr); + if SubStr^ = #0 then exit; + if Str^ = #0 then + begin + Result := nil; + exit; + end; + if Str^ <> SubStr^ then break; + until (FALSE); + end; + Inc(Result); + until (Result^ = #0); + Result := nil; +end; + +function StrIndexW(const aStr, aSubStr: PWideChar):integer; +var + p:pWideChar; +begin + p:=StrPosW(aStr,aSubStr); + if p=nil then + result:=0 + else + result:=(p-aStr)+1; //!!!! +end; + +// ----- filenames ----- + +function ChangeExt(src,ext:PAnsiChar):PAnsiChar; +var + i,j:integer; +begin + i:=StrLen(src); + j:=i; + while (i>0) and (src[i]<>'\') and (src[i]<>':') and (src[i]<>'.') do dec(i); + if src[i]<>'.' then + begin + i:=j; + src[i]:='.'; + end; + if ext=nil then + ext:=''; + StrCopy(src+i+1,ext); + result:=src; +end; + +function ChangeExtW(src,ext:PWideChar):PWideChar; +var + i,j:integer; +begin + i:=StrLenW(src); + j:=i; + while (i>0) and (src[i]<>'\') and (src[i]<>':') and (src[i]<>'.') do dec(i); + if src[i]<>'.' then + begin + i:=j; + src[i]:='.'; + end; + if ext=nil then + ext:=''; + StrCopyW(src+i+1,ext); + result:=src; +end; + +function Extract(s:PAnsiChar;name:Boolean=true):PAnsiChar; +var + i,j:integer; +begin + i:=StrLen(s)-1; + j:=i; + while (i>=0) and ((s[i]<>'\') and (s[i]<>'/')) do dec(i); + if name then + begin + mGetMem(result,(j-i+1)); + StrCopy(result,s+i+1); + end + else + begin + StrDup(result,s,i+1); + end; +end; + +function ExtractW(s:pWideChar;name:Boolean=true):pWideChar; +var + i,j:integer; +begin + i:=StrLenW(s)-1; + j:=i; + while (i>=0) and ((s[i]<>'\') and (s[i]<>'/')) do dec(i); + if name then + begin + mGetMem(result,(j-i+1)*SizeOf(WideChar)); + StrCopyW(result,s+i+1); + end + else + begin + StrDupW(result,s,i+1); + end; +end; + +function GetExt(fname,dst:pWideChar;maxlen:dword=100):pWideChar; +var + ppc,pc:PWideChar; +begin + result:=dst; + dst^:=#0; + if fname<>nil then + begin + pc:=strendw(fname)-1; + while (pc>fname) and ((pc^='"') or (pc^=' ')) do dec(pc); + ppc:=pc+1; + while (pc>fname) and (pc^<>'.') do + begin + if maxlen=0 then exit; + if not (AnsiChar(pc^) in ['0'..'9','A'..'Z','_','a'..'z']) then exit; + dec(maxlen); + dec(pc); //empty name not allowed! + end; + if pc>fname then + begin + repeat + inc(pc); + if pc=ppc then + begin + dst^:=#0; + break; + end; + if (pc^>='a') and (pc^<='z') then + dst^:=WideChar(ord(pc^)-$20) + else + dst^:=pc^; + inc(dst); + until false; + end; + end; +end; + +function GetExt(fname,dst:PAnsiChar;maxlen:dword=100):PAnsiChar; +var + ppc,pc:PAnsiChar; +begin + result:=dst; + dst^:=#0; + if fname<>nil then + begin + pc:=StrEnd(fname)-1; + while (pc>fname) and ((pc^='"') or (pc^=' ')) do dec(pc); + ppc:=pc+1; + while (pc>fname) and (pc^<>'.') do + begin + if maxlen=0 then exit; + if not (AnsiChar(pc^) in ['0'..'9','A'..'Z','_','a'..'z']) then exit; + dec(maxlen); + dec(pc); //empty name not allowed! + end; + if pc>fname then + begin + repeat + inc(pc); + if pc=ppc then + begin + dst^:=#0; + break; + end; + if (pc^>='a') and (pc^<='z') then + dst^:=AnsiChar(ord(pc^)-$20) + else + dst^:=pc^; + inc(dst); + until false; + end; + end; +end; + +type + PDayTable = ^TDayTable; + TDayTable = array [0..11] of cardinal; + +const + MonthDays: array [Boolean] of TDayTable = + ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), + (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)); + +const + DateDelta = 693594; +{ Days between TDateTime basis (12/31/1899) and Unix time_t basis (1/1/1970) } + UnixDateDelta = 25569; + +function IsLeapYear(Year:Word):Boolean; +begin + Result:=(Year mod 4=0) and ((Year mod 100<>0) or (Year mod 400=0)); +end; + +function EncodeTime(Hour, Min, Sec: cardinal): TDateTime; +begin + result := (Hour*3600 + Min*60 + Sec) / 86400; +end; + +function EncodeDate(Year, Month, Day: cardinal):TDateTime; +var + DayTable: PDayTable; +begin + DayTable := @MonthDays[IsLeapYear(Year)]; + dec(Month); + while Month>0 do + begin + dec(Month); + inc(Day,DayTable^[Month]); + end; + + dec(Year); + result := Year * 365 + Year div 4 - Year div 100 + Year div 400 + Day - DateDelta; +end; + +function Timestamp(Year,Month,Day:cardinal;Hour:cardinal=0;Min:cardinal=0;Sec:cardinal=0):dword; +var + t:tDateTime; +begin + t := EncodeDate(Year, Month, Day); + if t >= 0 then + t := t + EncodeTime(Hour, Min, Sec) + else + t := t - EncodeTime(Hour, Min, Sec); + result:=Round((t - UnixDateDelta) * 86400) +end; + +function GetCurrentTime:dword; +var + st:tSystemTime; +begin + GetSystemTime(st); + result:=Timestamp(st.wYear,st.wMonth,st.wDay,st.wHour,st.wMinute,st.wSecond); +end; + +function TimeToInt(stime:PAnsiChar):integer; +var + hour,min,sec,len,i:integer; +begin + len:=StrLen(stime); + i:=0; + sec :=0; + min :=0; + hour:=0; + while i'9') then + begin + if min>0 then + hour:=min; + min:=sec; + sec:=0; + end + else + sec:=sec*10+ord(stime[i])-ord('0'); + inc(i); + end; + result:=hour*3600+min*60+sec; +end; + +function TimeToInt(stime:PWideChar):integer; +var + buf:array [0..63] of AnsiChar; +begin + result:=TimeToInt(FastWideToAnsiBuf(stime,buf)); +end; + +function IntToTime(dst:PAnsiChar;time:integer):PAnsiChar; +var + day,hour,min,sec:array [0..7] of AnsiChar; + d,h:integer; +begin + result:=dst; + h:=time div 3600; + dec(time,h*3600); + IntToStr(sec,(time mod 60),2); + d:=h div 24; + if d>0 then + begin + h:=h mod 24; + IntToStr(day,d); + dst^:=day[0]; inc(dst); + if day[1]<>#0 then // now only 99 days max + begin + dst^:=day[1]; inc(dst); + end; + dst^:=' '; inc(dst); + end; + if h>0 then + begin + IntToStr(hour,h); + IntToStr(min,(time div 60),2); + dst^:=hour[0]; inc(dst); + if hour[1]<>#0 then + begin + dst^:=hour[1]; inc(dst); + end; + dst^:=':'; inc(dst); + dst^:=min[0]; inc(dst); + dst^:=min[1]; inc(dst); + end + else + begin + IntToStr(min,time div 60); + dst^:=min[0]; inc(dst); + if min[1]<>#0 then + begin + dst^:=min[1]; inc(dst); + end; + end; + dst^:=':'; inc(dst); + dst^:=sec[0]; inc(dst); + dst^:=sec[1]; inc(dst); + dst^:=#0; +end; + +function IntToTime(dst:pWideChar;time:integer):pWideChar; +var + buf:array [0..63] of AnsiChar; +begin + result:=FastAnsiToWideBuf(IntToTime(buf,time),dst); +end; + +function StrToInt(src:pWideChar):integer; +var + sign:boolean; +begin + result:=0; + if src<>nil then + begin + sign:=src^='-'; + if sign then inc(src); + while src^<>#0 do + begin + if (src^>='0') and (src^<='9') then + result:=result*10+ord(src^)-ord('0') + else + break; + inc(src); + end; + if sign then result:=-result; + end; +end; + +function StrToInt(src:PAnsiChar):integer; +var + sign:boolean; +begin + result:=0; + if src<>nil then + begin + sign:=src^='-'; + if sign then inc(src); + while src^<>#0 do + begin + if (src^>='0') and (src^<='9') then + result:=result*10+ord(src^)-ord('0') + else + break; + inc(src); + end; + if sign then result:=-result; + end; +end; + +function IntToStr(dst:PAnsiChar;Value:integer;Digits:integer=0):PAnsiChar; +var + i:dword; +begin + if Digits<=0 then + begin + if Value<0 then + Digits:=1 + else + Digits:=0; + i:=ABS(Value); + repeat + i:=i div 10; + inc(Digits); + until i=0; + end; + dst[Digits]:=#0; + i:=ABS(Value); + repeat + dec(Digits); + dst[Digits]:=AnsiChar(ord('0')+(i mod 10)); + i:=i div 10; + if (Value<0) and (Digits=1) then + begin + dst[0]:='-'; + break; + end; + until Digits=0; + result:=dst; +end; + +function IntToStr(dst:pWideChar;Value:integer;Digits:integer=0):pWideChar; +var + i:dword; +begin + if Digits<=0 then + begin + if Value<0 then + Digits:=1 + else + Digits:=0; + i:=ABS(Value); + repeat + i:=i div 10; + inc(Digits); + until i=0; + end; + dst[Digits]:=#0; + i:=ABS(Value); + repeat + dec(Digits); + dst[Digits]:=WideChar(ord('0')+(i mod 10)); + i:=i div 10; + if (Value<0) and (Digits=1) then + begin + dst[0]:='-'; + break; + end; + until Digits=0; + result:=dst; +end; + +function HexToInt(src:pWideChar):integer; +begin + result:=0; + while src^<>#0 do + begin + if (src^>='0') and (src^<='9') then + result:=result*16+ord(src^)-ord('0') + else if ((src^>='A') and (src^<='F')) then + result:=result*16+ord(src^)-ord('A')+10 + else if ((src^>='a') and (src^<='f')) then + result:=result*16+ord(src^)-ord('a')+10 + else + break; + inc(src); + end; +end; + +function HexToInt(src:PAnsiChar):integer; +begin + result:=0; + while src^<>#0 do + begin + if (src^>='0') and (src^<='9') then + result:=result*16+ord(src^)-ord('0') + else if ((src^>='A') and (src^<='F')) then + result:=result*16+ord(src^)-ord('A')+10 + else if ((src^>='a') and (src^<='f')) then + result:=result*16+ord(src^)-ord('a')+10 + else + break; + inc(src); + end; +end; + +function IntToHex(dst:pWidechar;Value:dword;Digits:integer=0):pWideChar; +var + i:dword; +begin + if Digits<=0 then + begin + Digits:=0; + i:=Value; + repeat + i:=i shr 4; + inc(Digits); + until i=0; + end; + dst[Digits]:=#0; + repeat + Dec(Digits); + dst[Digits]:=WideChar(HexDigitChr[Value and $F]); + Value:=Value shr 4; + until Digits=0; + result:=dst; +end; + +function IntToHex(dst:PAnsiChar;Value:dword;Digits:integer=0):PAnsiChar; +var + i:dword; +begin + if Digits<=0 then + begin + Digits:=0; + i:=Value; + repeat + i:=i shr 4; + inc(Digits); + until i=0; + end; + dst[Digits]:=#0; + repeat + Dec(Digits); + dst[Digits]:=HexDigitChr[Value and $F]; + Value:=Value shr 4; + until Digits=0; + result:=dst; +end; + +procedure UpperCase(src:pWideChar); +var + c:WideChar; +begin + if src<>nil then + begin + while src^<>#0 do + begin + c:=src^; + if (c>='a') and (c<='z') then + src^:=WideChar(ord(c)-$20); + inc(src); + end; + end; +end; + +procedure LowerCase(src:pWideChar); +var + c:WideChar; +begin + if src<>nil then + begin + while src^<>#0 do + begin + c:=src^; + if (c>='A') and (c<='Z') then + src^:=WideChar(ord(c)+$20); + inc(src); + end; + end; +end; + +function GetPairChar(ch:AnsiChar):AnsiChar; +begin + case ch of + '[': result:=']'; + '<': result:='>'; + '(': result:=')'; + '{': result:='}'; + else // ' and " too + result:=ch; + end; +end; + +function GetPairChar(ch:WideChar):WideChar; +begin + case ch of + '[': result:=']'; + '<': result:='>'; + '(': result:=')'; + '{': result:='}'; + else // ' and " too + result:=ch; + end; +end; + +function FastWideToAnsiBuf(src:PWideChar;dst:PAnsiChar;len:cardinal=dword(-1)):PAnsiChar; +begin + result:=dst; + if src<>nil then + begin + repeat + dst^:=AnsiChar(src^); + if src^=#0 then + break; + dec(len); + if len=0 then + begin + (dst+1)^:=#0; + break; + end; + inc(src); + inc(dst); + until false; + end + else + dst^:=#0; +end; + +function FastWideToAnsi(src:PWideChar;var dst:PAnsiChar):PAnsiChar; +begin + if src=nil then + dst:=nil + else + begin + mGetMem(dst,StrLenW(src)+1); + FastWideToAnsiBuf(src,dst); + end; + result:=dst; +end; + +function FastAnsiToWideBuf(src:PAnsiChar;dst:PWideChar;len:cardinal=dword(-1)):PWideChar; +begin + result:=dst; + if src<>nil then + begin + repeat + dst^:=WideChar(src^); + if src^=#0 then + break; + dec(len); + if len=0 then + begin + (dst+1)^:=#0; + break; + end; + inc(src); + inc(dst); + until false; + end + else + dst^:=#0; +end; + +function FastAnsiToWide(src:PAnsiChar;var dst:PWideChar):PWideChar; +begin + if src=nil then + dst:=nil + else + begin + mGetMem(dst,(StrLen(src)+1)*SizeOf(WideChar)); + FastAnsiToWideBuf(src,dst); + end; + result:=dst; +end; + +function isPathAbsolute(path:pWideChar):boolean; +begin + result:=((path[1]=':') and (path[2]='\')) or ((path[0]='\') {and (path[1]='\')}) or + (StrPosW(path,'://')<>nil); +end; + +function isPathAbsolute(path:PAnsiChar):boolean; +begin + result:=((path[1]=':') and (path[2]='\')) or ((path[0]='\') {and (path[1]='\')}) or + (StrPos(path,'://')<>nil); +end; + +begin + CheckSystem; +end. diff --git a/delphi/Awkward/utils/compilers.inc b/delphi/Awkward/utils/compilers.inc new file mode 100644 index 0000000..af89289 --- /dev/null +++ b/delphi/Awkward/utils/compilers.inc @@ -0,0 +1,735 @@ +{$IFDEF VER210} // Delphi 2010 + {$DEFINE COMPILER13} + {$DEFINE VCL71} + {$DEFINE DELPHI13} + {$DEFINE DELPHI2010} + {$DEFINE BCB13} + {$DEFINE BCB2010} + {$DEFINE BDS7} + {$DEFINE BDS2010} +{$ENDIF} + +{$IFDEF VER200} + {$DEFINE COMPILER12} + {$DEFINE VCL71} + {$DEFINE DELPHI12} + {$DEFINE DELPHI2009} + {$DEFINE BCB12} + {$DEFINE BCB2009} + {$DEFINE BDS6} + {$DEFINE BDS2009} +{$ENDIF} + +{$IFDEF VER185} + {$DEFINE COMPILER11} + {$DEFINE VCL71} + {$DEFINE DELPHI11} + {$DEFINE DELPHI2007} + {$DEFINE BCB11} + {$DEFINE BCB2007} + {$DEFINE BDS5} + {$DEFINE BDS2007} + {$UNDEF VER180} +{$ENDIF} + +{$IFDEF VER180} + {$DEFINE COMPILER10} + {$DEFINE VCL71} + {$DEFINE DELPHI10} + {$DEFINE DELPHI2006} + {$DEFINE BCB10} + {$DEFINE BCB2006} + {$DEFINE BDS4} + {$DEFINE BDS2006} +{$ENDIF} + +{$IFDEF VER170} + {$DEFINE COMPILER9} + {$DEFINE VCL71} + {$DEFINE DELPHI9} + {$DEFINE DELPHI2005} + {$DEFINE BDS3} + {$DEFINE BDS2005} +{$ENDIF} + +{$IFDEF VER160} + {$DEFINE COMPILER8} + {$DEFINE VCL71} + {$DEFINE DELPHI8} + {$DEFINE BDS2} +{$ENDIF} + +{$IFDEF VER150} + {$DEFINE COMPILER7} + {$IFDEF LINUX} + {$DEFINE CLX10} + {$ELSE} + {$DEFINE VCL70} + {$DEFINE CLX10} + {$IFDEF BCB} + {$DEFINE BCB7} + {$ELSE} + {$DEFINE DELPHI7} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF VER140} + {$DEFINE COMPILER6} + {$IFDEF LINUX} + {$DEFINE CLX10} + {$IFDEF CONDITIONALEXPRESSIONS} + {$IFDEF CompilerVersion} + {.$IF System.RTLVersion = 14.1} + {.$DEFINE KYLIX2} + {.$IFEND} + {.$IF System.RTLVersion = 14.5} + {.$DEFINE KYLIX3} + {.$IFEND} + {$ELSE} + {$DEFINE KYLIX1} + {$ENDIF} + {$ENDIF} + {$ELSE} + {$DEFINE VCL60} + {$DEFINE CLX10} + {$IFDEF BCB} + {$DEFINE BCB6} + {$ELSE} + {$DEFINE DELPHI6} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF VER130} + {$DEFINE COMPILER5} + {$DEFINE VCL50} + {$IFDEF BCB} + {$DEFINE BCB5} + {$ELSE} + {$DEFINE DELPHI5} + {$ENDIF} +{$ENDIF} + +{$IFDEF VER125} + {$DEFINE COMPILER4} + {$DEFINE VCL40} + {$DEFINE BCB4} +{$ENDIF} + +{$IFDEF VER120} + {$DEFINE COMPILER4} + {$DEFINE VCL40} + {$DEFINE DELPHI4} +{$ENDIF} + +{$IFDEF VER110} + {$DEFINE COMPILER35} + {$DEFINE VCL30} + {$DEFINE BCB3} +{$ENDIF} + +{$IFDEF VER100} + {$DEFINE COMPILER3} + {$DEFINE VCL30} + {$DEFINE DELPHI3} +{$ENDIF} + +{$IFDEF VER93} + {$DEFINE COMPILER2} + {$DEFINE VCL20} + {$DEFINE BCB1} +{$ENDIF} + +{$IFDEF VER90} + {$DEFINE COMPILER2} + {$DEFINE VCL20} + {$DEFINE DELPHI2} +{$ENDIF} + +{$IFDEF VER80} + {$DEFINE COMPILER1} + {$DEFINE VCL10} + {$DEFINE DELPHI1} +{$ENDIF} + +// DELPHIX_UP from DELPHIX mappings + +{$IFDEF DELPHI13} + {$DEFINE DELPHI} + {$DEFINE DELPHI13_UP} + {$DEFINE DELPHI12_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI2010} + {$DEFINE DELPHI2010_UP} + {$DEFINE DELPHI2009_UP} + {$DEFINE DELPHI2007_UP} + {$DEFINE DELPHI2006_UP} + {$DEFINE DELPHI2005_UP} +{$ENDIF} + +{$IFDEF DELPHI12} + {$DEFINE DELPHI} + {$DEFINE DELPHI12_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI2009} + {$DEFINE DELPHI2009_UP} + {$DEFINE DELPHI2007_UP} + {$DEFINE DELPHI2006_UP} + {$DEFINE DELPHI2005_UP} +{$ENDIF} + +{$IFDEF DELPHI11} + {$DEFINE DELPHI} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI2007} + {$DEFINE DELPHI2007_UP} + {$DEFINE DELPHI2006_UP} + {$DEFINE DELPHI2005_UP} +{$ENDIF} + +{$IFDEF DELPHI10} + {$DEFINE DELPHI} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI2006} + {$DEFINE DELPHI2006_UP} + {$DEFINE DELPHI2005_UP} +{$ENDIF} + +{$IFDEF DELPHI9} + {$DEFINE DELPHI} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI2005} + {$DEFINE DELPHI2005_UP} +{$ENDIF} + +{$IFDEF DELPHI8} + {$DEFINE DELPHI} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI7} + {$DEFINE DELPHI} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI6} + {$DEFINE DELPHI} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI5} + {$DEFINE DELPHI} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI4} + {$DEFINE DELPHI} + {$DEFINE DELPHI4_UP} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI3} + {$DEFINE DELPHI} + {$DEFINE DELPHI3_UP} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI2} + {$DEFINE DELPHI} + {$DEFINE DELPHI2_UP} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +{$IFDEF DELPHI1} + {$DEFINE DELPHI} + {$DEFINE DELPHI1_UP} +{$ENDIF} + +// BCBX_UP from BCBX mappings + +{$IFDEF BCB12} + {$DEFINE BCB} + {$DEFINE BCB12_UP} + {$DEFINE BCB11_UP} + {$DEFINE BCB10_UP} + {$DEFINE BCB7_UP} + {$DEFINE BCB6_UP} + {$DEFINE BCB5_UP} + {$DEFINE BCB4_UP} + {$DEFINE BCB3_UP} + {$DEFINE BCB1_UP} +{$ENDIF} + +{$IFDEF BCB2008} + {$DEFINE BCB2008_UP} + {$DEFINE BCB2007_UP} + {$DEFINE BCB2006_UP} +{$ENDIF} + +{$IFDEF BCB11} + {$DEFINE BCB} + {$DEFINE BCB11_UP} + {$DEFINE BCB10_UP} + {$DEFINE BCB7_UP} + {$DEFINE BCB6_UP} + {$DEFINE BCB5_UP} + {$DEFINE BCB4_UP} + {$DEFINE BCB3_UP} + {$DEFINE BCB1_UP} +{$ENDIF} + +{$IFDEF BCB2007} + {$DEFINE BCB2007_UP} + {$DEFINE BCB2006_UP} +{$ENDIF} + +{$IFDEF BCB10} + {$DEFINE BCB} + {$DEFINE BCB10_UP} + {$DEFINE BCB7_UP} + {$DEFINE BCB6_UP} + {$DEFINE BCB5_UP} + {$DEFINE BCB4_UP} + {$DEFINE BCB3_UP} + {$DEFINE BCB1_UP} +{$ENDIF} + +{$IFDEF BCB2006} + {$DEFINE BCB2006_UP} +{$ENDIF} + +{$IFDEF BCB7} + {$DEFINE BCB} + {$DEFINE BCB7_UP} + {$DEFINE BCB6_UP} + {$DEFINE BCB5_UP} + {$DEFINE BCB4_UP} + {$DEFINE BCB3_UP} + {$DEFINE BCB1_UP} +{$ENDIF} + +{$IFDEF BCB6} + {$DEFINE BCB} + {$DEFINE BCB6_UP} + {$DEFINE BCB5_UP} + {$DEFINE BCB4_UP} + {$DEFINE BCB3_UP} + {$DEFINE BCB1_UP} +{$ENDIF} + +{$IFDEF BCB5} + {$DEFINE BCB} + {$DEFINE BCB5_UP} + {$DEFINE BCB4_UP} + {$DEFINE BCB3_UP} + {$DEFINE BCB1_UP} +{$ENDIF} + +{$IFDEF BCB4} + {$DEFINE BCB} + {$DEFINE BCB4_UP} + {$DEFINE BCB3_UP} + {$DEFINE BCB1_UP} +{$ENDIF} + +{$IFDEF BCB3} + {$DEFINE BCB} + {$DEFINE BCB3_UP} + {$DEFINE BCB1_UP} +{$ENDIF} + +{$IFDEF BCB1} + {$DEFINE BCB} + {$DEFINE BCB1_UP} +{$ENDIF} + +// KYLIXX_UP from KYLIXX mappings + +{$IFDEF KYLIX3} + {$DEFINE KYLIX} + {$DEFINE KYLIX3_UP} + {$DEFINE KYLIX2_UP} + {$DEFINE KYLIX1_UP} +{$ENDIF} + +{$IFDEF KYLIX2} + {$DEFINE KYLIX} + {$DEFINE KYLIX2_UP} + {$DEFINE KYLIX1_UP} +{$ENDIF} + +{$IFDEF KYLIX1} + {$DEFINE KYLIX} + {$DEFINE KYLIX1_UP} +{$ENDIF} + +// BDSXX_UP from BDSXX mappings + +{$IFDEF BDS6} + {$DEFINE BDS} + {$DEFINE BDS6_UP} + {$DEFINE BDS5_UP} + {$DEFINE BDS4_UP} + {$DEFINE BDS3_UP} + {$DEFINE BDS2_UP} + {$DEFINE BDS1_UP} +{$ENDIF} + +{$IFDEF BDS2008} + {$DEFINE BDS2008_UP} + {$DEFINE BDS2007_UP} + {$DEFINE BDS2006_UP} + {$DEFINE BDS2005_UP} +{$ENDIF} + +{$IFDEF BDS5} + {$DEFINE BDS} + {$DEFINE BDS5_UP} + {$DEFINE BDS4_UP} + {$DEFINE BDS3_UP} + {$DEFINE BDS2_UP} + {$DEFINE BDS1_UP} +{$ENDIF} + +{$IFDEF BDS2007} + {$DEFINE BDS2007_UP} + {$DEFINE BDS2006_UP} + {$DEFINE BDS2005_UP} +{$ENDIF} + +{$IFDEF BDS4} + {$DEFINE BDS} + {$DEFINE BDS4_UP} + {$DEFINE BDS3_UP} + {$DEFINE BDS2_UP} + {$DEFINE BDS1_UP} +{$ENDIF} + +{$IFDEF BDS2006} + {$DEFINE BDS2006_UP} + {$DEFINE BDS2005_UP} +{$ENDIF} + +{$IFDEF BDS3} + {$DEFINE BDS} + {$DEFINE BDS3_UP} + {$DEFINE BDS2_UP} + {$DEFINE BDS1_UP} +{$ENDIF} + +{$IFDEF BDS2005} + {$DEFINE BDS2005_UP} +{$ENDIF} + +{$IFDEF BDS2} + {$DEFINE BDS} + {$DEFINE BDS2_UP} + {$DEFINE BDS1_UP} +{$ENDIF} + +{$IFDEF BDS1} + {$DEFINE BDS} + {$DEFINE BDS1_UP} +{$ENDIF} + +// COMPILERX_UP from COMPILERX mappings + +{$IFDEF COMPILER12} + {$DEFINE COMPILER12_UP} + {$DEFINE COMPILER11_UP} + {$DEFINE COMPILER10_UP} + {$DEFINE COMPILER9_UP} + {$DEFINE COMPILER8_UP} + {$DEFINE COMPILER7_UP} + {$DEFINE COMPILER6_UP} + {$DEFINE COMPILER5_UP} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER11} + {$DEFINE COMPILER11_UP} + {$DEFINE COMPILER10_UP} + {$DEFINE COMPILER9_UP} + {$DEFINE COMPILER8_UP} + {$DEFINE COMPILER7_UP} + {$DEFINE COMPILER6_UP} + {$DEFINE COMPILER5_UP} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER10} + {$DEFINE COMPILER10_UP} + {$DEFINE COMPILER9_UP} + {$DEFINE COMPILER8_UP} + {$DEFINE COMPILER7_UP} + {$DEFINE COMPILER6_UP} + {$DEFINE COMPILER5_UP} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER9} + {$DEFINE COMPILER9_UP} + {$DEFINE COMPILER8_UP} + {$DEFINE COMPILER7_UP} + {$DEFINE COMPILER6_UP} + {$DEFINE COMPILER5_UP} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER8} + {$DEFINE COMPILER8_UP} + {$DEFINE COMPILER7_UP} + {$DEFINE COMPILER6_UP} + {$DEFINE COMPILER5_UP} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER7} + {$DEFINE COMPILER7_UP} + {$DEFINE COMPILER6_UP} + {$DEFINE COMPILER5_UP} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER6} + {$DEFINE COMPILER6_UP} + {$DEFINE COMPILER5_UP} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER5} + {$DEFINE COMPILER5_UP} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER4} + {$DEFINE COMPILER4_UP} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER35} + {$DEFINE COMPILER35_UP} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER3} + {$DEFINE COMPILER3_UP} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER2} + {$DEFINE COMPILER2_UP} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +{$IFDEF COMPILER1} + {$DEFINE COMPILER1_UP} +{$ENDIF} + +// VCLXX_UP from VCLXX mappings + +{$IFDEF VCL71} + {$DEFINE VCL71_UP} + {$DEFINE VCL70_UP} + {$DEFINE VCL60_UP} + {$DEFINE VCL50_UP} + {$DEFINE VCL40_UP} + {$DEFINE VCL30_UP} + {$DEFINE VCL20_UP} + {$DEFINE VCL10_UP} +{$ENDIF} + +{$IFDEF VCL70} + {$DEFINE VCL70_UP} + {$DEFINE VCL60_UP} + {$DEFINE VCL50_UP} + {$DEFINE VCL40_UP} + {$DEFINE VCL30_UP} + {$DEFINE VCL20_UP} + {$DEFINE VCL10_UP} +{$ENDIF} + +{$IFDEF VCL60} + {$DEFINE VCL60_UP} + {$DEFINE VCL50_UP} + {$DEFINE VCL40_UP} + {$DEFINE VCL30_UP} + {$DEFINE VCL20_UP} + {$DEFINE VCL10_UP} +{$ENDIF} + +{$IFDEF VCL50} + {$DEFINE VCL50_UP} + {$DEFINE VCL40_UP} + {$DEFINE VCL30_UP} + {$DEFINE VCL20_UP} + {$DEFINE VCL10_UP} +{$ENDIF} + +{$IFDEF VCL40} + {$DEFINE VCL40_UP} + {$DEFINE VCL30_UP} + {$DEFINE VCL20_UP} + {$DEFINE VCL10_UP} +{$ENDIF} + +{$IFDEF VCL30} + {$DEFINE VCL30_UP} + {$DEFINE VCL20_UP} + {$DEFINE VCL10_UP} +{$ENDIF} + +{$IFDEF VCL20} + {$DEFINE VCL20_UP} + {$DEFINE VCL10_UP} +{$ENDIF} + +{$IFDEF VCL10} + {$DEFINE VCL10_UP} +{$ENDIF} + +// CLXXX_UP from CLXXX mappings + +{$IFDEF CLX10} + {$DEFINE CLX10_UP} +{$ENDIF} + +//------------------------ + +{$ALIGN ON} +{$BOOLEVAL OFF} + +{$ifdef COMPILER_7_UP} + {$define THEME_7_UP} { Allows experimental theme support on pre-Delphi 7. } +{$endif} + +{$IFDEF COMPILER_6_UP} + {$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! } +{$ENDIF} + +{$IFDEF COMPILER_7_UP} + {$WARN UNSAFE_CODE OFF} { We are not going to be "safe"! } + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} +{$ENDIF} diff --git a/delphi/Awkward/utils/dbsettings.pas b/delphi/Awkward/utils/dbsettings.pas new file mode 100644 index 0000000..05482e6 --- /dev/null +++ b/delphi/Awkward/utils/dbsettings.pas @@ -0,0 +1,421 @@ +unit dbsettings; +interface + +uses windows,m_api; + +function DBReadByte (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:byte =0):byte; +function DBReadWord (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:word =0):word; +function DBReadDword(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:dword=0):dword; + +function DBReadSetting (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;dbv:PDBVARIANT):Integer; +function DBReadSettingStr(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;dbv:PDBVARIANT):Integer; + +function DBReadStringLength(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar):integer; +function DBReadString (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar; + default:PAnsiChar=nil;enc:integer=DBVT_ASCIIZ):PAnsiChar; +function DBReadUTF8 (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:PAnsiChar=nil):PAnsiChar; +function DBReadUnicode(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:PWideChar=nil):PWideChar; + +function DBReadStruct (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar; + ptr:pointer;size:dword):Integer; +function DBWriteStruct(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar; + ptr:pointer;size:dword):Integer; + +function DBWriteSetting(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;dbv:PDBVARIANT):Integer; +function DBWriteByte (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:Byte ):Integer; +function DBWriteWord (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:Word ):Integer; +function DBWriteDWord(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:dword):Integer; + +function DBWriteString (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar; + val:PAnsiChar;enc:integer=DBVT_ASCIIZ):Integer; +function DBWriteUTF8 (hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:PAnsiChar):Integer; +function DBWriteUnicode(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:PWideChar):Integer; + +function DBFreeVariant(dbv:PDBVARIANT):integer; +function DBDeleteSetting(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar):Integer; +function DBDeleteGroup(hContact:THANDLE;szModule:PAnsiChar):integer; +function DBDeleteModule(szModule:PAnsiChar):integer; // 0.8.0+ + +function DBGetSettingType(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar):integer; + +implementation + +function DBReadByte(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:byte=0):byte; +var + dbv:TDBVARIANT; + cgs:TDBCONTACTGETSETTING; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + cgs.pValue :=@dbv; + If PluginLink^.CallService(MS_DB_CONTACT_GETSETTING,hContact,lParam(@cgs))<>0 then + Result:=default + else + Result:=dbv.bVal; +end; + +function DBReadWord(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:word=0):word; +var + dbv:TDBVARIANT; + cgs:TDBCONTACTGETSETTING; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + cgs.pValue :=@dbv; + If PluginLink^.CallService(MS_DB_CONTACT_GETSETTING,hContact,lParam(@cgs))<>0 then + Result:=default + else + Result:=dbv.wVal; +end; + +function DBReadDword(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:dword=0):dword; +var + dbv:TDBVARIANT; + cgs:TDBCONTACTGETSETTING; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + cgs.pValue :=@dbv; + If PluginLink^.CallService(MS_DB_CONTACT_GETSETTING,hContact,lParam(@cgs))<>0 then + Result:=default + else + Result:=dbv.dVal; +end; + +function DBReadSetting(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;dbv:PDBVARIANT):Integer; +var + cgs:TDBCONTACTGETSETTING; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + cgs.pValue :=dbv; + Result:=PluginLink^.CallService(MS_DB_CONTACT_GETSETTING,hContact,lParam(@cgs)); +end; + +function DBReadSettingStr(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;dbv:PDBVARIANT):Integer; +var + cgs:TDBCONTACTGETSETTING; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + cgs.pValue :=dbv; + Result:=PluginLink^.CallService(MS_DB_CONTACT_GETSETTING_STR,hContact,lParam(@cgs)); +end; + +function DBReadStringLength(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar):integer; +var + cgs:TDBCONTACTGETSETTING; + dbv:TDBVARIANT; + i:integer; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + cgs.pValue :=@dbv; + i:=PluginLink^.CallService(MS_DB_CONTACT_GETSETTING_STR,hContact,lParam(@cgs)); + if (i<>0) or (dbv.szVal.a=nil) or (dbv.szVal.a^=#0) then + result:=0 + else + result:=lstrlena(dbv.szVal.a); + if i=0 then + DBFreeVariant(@dbv); +end; + +function DBReadString(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar; + default:PAnsiChar=nil;enc:integer=DBVT_ASCIIZ):PAnsiChar; +var + cgs:TDBCONTACTGETSETTING; + dbv:TDBVARIANT; + i:integer; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + cgs.pValue :=@dbv; + dbv._type :=enc; + i:=PluginLink^.CallService(MS_DB_CONTACT_GETSETTING_STR,hContact,lParam(@cgs)); + if i=0 then + default:=dbv.szVal.a; + if (default=nil) or (default^=#0) then + result:=nil + else + begin + result:=mmi.malloc(lstrlena(default)+1); + if result<>nil then + lstrcpya(result,default); + end; + if i=0 then + DBFreeVariant(@dbv); +end; + +function DBReadUTF8(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:PAnsiChar=nil):PAnsiChar; +begin + result:=DBReadString(hContact,szModule,szSetting,default,DBVT_UTF8); +end; + +function DBReadUnicode(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;default:PWideChar=nil):PWideChar; +var + cgs:TDBCONTACTGETSETTING; + dbv:TDBVARIANT; + i:integer; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + cgs.pValue :=@dbv; + dbv._type :=DBVT_WCHAR; + i:=PluginLink^.CallService(MS_DB_CONTACT_GETSETTING_STR,hContact,lParam(@cgs)); + if i=0 then + default:=dbv.szVal.w; + if (default=nil) or (default^=#0) then + result:=nil + else + begin + result:=mmi.malloc((lstrlenw(default)+1)*SizeOf(WideChar)); + if result<>nil then + lstrcpyw(result,default); + end; + if i=0 then + DBFreeVariant(@dbv); +end; + +function DBReadStruct(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar; + ptr:pointer;size:dword):Integer; +var + dbv:TDBVariant; +begin + dbv._type:=DBVT_BLOB; + dbv.pbVal:=nil; + if (DBReadSetting(0,szModule,szSetting,@dbv)=0) and + (dbv.pbVal<>nil) and (dbv.cpbVal=size) then + begin + move(dbv.pbVal^,ptr^,size); + DBFreeVariant(@dbv); + result:=1; + end + else + result:=0; +end; + +function DBWriteStruct(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar; + ptr:pointer;size:dword):Integer; +var + cws:TDBCONTACTWRITESETTING; +begin + cws.szModule :=szModule; + cws.szSetting :=szSetting; + cws.value._type :=DBVT_BLOB; + cws.value.pbVal :=ptr; + cws.value.cpbVal:=size; + result:=PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING,0,lParam(@cws)); +end; + +function DBWriteSetting(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;dbv:PDBVARIANT):Integer; +var + cws: TDBCONTACTWRITESETTING; +begin + cws.szModule :=szModule; + cws.szSetting :=szSetting; + move(dbv^,cws.value,SizeOf(TDBVARIANT)); + Result := PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING, hContact, lParam(@cws)); +end; + +function DBWriteByte(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:Byte):Integer; +var + cws:TDBCONTACTWRITESETTING; +begin + cws.szModule :=szModule; + cws.szSetting :=szSetting; + cws.value._type:=DBVT_BYTE; + cws.value.bVal :=Val; + Result:=PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING,hContact,lParam(@cws)); +end; + +function DBWriteWord(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:Word):Integer; +var + cws:TDBCONTACTWRITESETTING; +begin + cws.szModule :=szModule; + cws.szSetting :=szSetting; + cws.value._type:=DBVT_WORD; + cws.value.wVal :=Val; + Result:=PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING,hContact,lParam(@cws)); +end; + +function DBWriteDWord(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:dword):Integer; +var + cws:TDBCONTACTWRITESETTING; +begin + cws.szModule :=szModule; + cws.szSetting :=szSetting; + cws.value._type:=DBVT_DWORD; + cws.value.dVal :=Val; + Result:=PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING,hContact,lParam(@cws)); +end; + +function DBWriteString(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar; + val:PAnsiChar;enc:integer=DBVT_ASCIIZ):Integer; +var + cws:TDBCONTACTWRITESETTING; +begin + cws.szModule :=szModule; + cws.szSetting :=szSetting; + cws.value._type :=enc; + if val=nil then + val:=''; + cws.value.szVal.a:=Val; + Result:=PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING,hContact,lParam(@cws)); +end; + +function DBWriteUTF8(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:PAnsiChar):Integer; +begin + result:=DBWriteString(hContact,szModule,szSetting,val,DBVT_UTF8); +end; + +function DBWriteUnicode(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar;val:PWideChar):Integer; +begin + result:=DBWriteString(hContact,szModule,szSetting,PAnsiChar(val),DBVT_WCHAR); +{ +var + cws:TDBCONTACTWRITESETTING; +begin + cws.szModule :=szModule; + cws.szSetting :=szSetting; + cws.value._type :=DBVT_WCHAR; + cws.value.szVal.w:=Val; + Result:=PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING,hContact,lParam(@cws)); +} +end; + +function DBFreeVariant(dbv:PDBVARIANT):integer; +begin + Result:=PluginLink^.CallService(MS_DB_CONTACT_FREEVARIANT,0,lParam(dbv)); +end; + +function DBDeleteSetting(hContact:THandle;szModule:PAnsiChar;szSetting:PAnsiChar):Integer; +var + cgs:TDBCONTACTGETSETTING; +begin + cgs.szModule :=szModule; + cgs.szSetting:=szSetting; + Result:=PluginLink^.CallService(MS_DB_CONTACT_DELETESETTING,hContact,lParam(@cgs)); +end; +{ +type + pdbenumrec = ^dbenumrec; + dbenumrec = record + num:integer; + ptr:PAnsiChar; + end; +function EnumSettingsProc(const szSetting:PAnsiChar;lParam:LPARAM):int; cdecl; +begin + with pdbenumrec(lParam)^ do + begin + lstrcpya(ptr,szSetting); + while ptr^<>#0 do inc(ptr); + inc(ptr); + inc(num); + end; + result:=0; +end; +// hContact = 0 +function DBDeleteGroup(hContact:THANDLE;szModule:PAnsiChar):integer; +var + ces:TDBCONTACTENUMSETTINGS; + cgs:TDBCONTACTGETSETTING; + p:PAnsiChar; + rec:dbenumrec; +begin + GetMem(p,65520); + rec.num :=0; + rec.ptr :=p; + ces.pfnEnumProc:=@EnumSettingsProc; + ces.szModule :=szModule; + ces.lParam :=integer(@rec); + ces.ofsSettings:=0; + result:=PluginLink^.CallService(MS_DB_CONTACT_ENUMSETTINGS,hContact,dword(@ces)); + cgs.szModule :=szModule; + rec.ptr:=p; + with rec do + while num>0 do + begin + dec(num); + cgs.szSetting:=ptr; + PluginLink^.CallService(MS_DB_CONTACT_DELETESETTING,hContact,lParam(@cgs)); + while ptr^<>#0 do inc(ptr); + inc(ptr); + end; + FreeMem(p); +end; +} +type + ppchar = ^pAnsiChar; + +function EnumSettingsProc(const szSetting:PAnsiChar;lParam:LPARAM):int; cdecl; +begin + lstrcpya(ppchar(lParam)^,szSetting); + while ppchar(lParam)^^<>#0 do inc(ppchar(lParam)^); + inc(ppchar(lParam)^); + result:=0; +end; +function EnumSettingsProcCalc(const szSetting:PAnsiChar;lParam:LPARAM):int; cdecl; +begin + inc(pdword(lParam)^,lstrlena(szSetting)+1); + result:=0; +end; +// hContact = 0 +function DBDeleteGroup(hContact:THANDLE;szModule:PAnsiChar):integer; +var + ces:TDBCONTACTENUMSETTINGS; + cgs:TDBCONTACTGETSETTING; + p:PAnsiChar; + num:integer; + ptr:pAnsiChar; +begin + ces.szModule:=szModule; + num:=0; + + ces.pfnEnumProc:=@EnumSettingsProcCalc; + ces.lParam :=integer(@num); + ces.ofsSettings:=0; + PluginLink^.CallService(MS_DB_CONTACT_ENUMSETTINGS,hContact,dword(@ces)); + + GetMem(p,num+1); + ptr:=p; + ces.pfnEnumProc:=@EnumSettingsProc; + ces.lParam :=integer(@ptr); + ces.ofsSettings:=0; + result:=PluginLink^.CallService(MS_DB_CONTACT_ENUMSETTINGS,hContact,dword(@ces)); + ptr^:=#0; + + cgs.szModule:=szModule; + ptr:=p; + while ptr^<>#0 do + begin + cgs.szSetting:=ptr; + PluginLink^.CallService(MS_DB_CONTACT_DELETESETTING,hContact,lParam(@cgs)); + while ptr^<>#0 do inc(ptr); + inc(ptr); + end; + FreeMem(p); +end; + +function DBDeleteModule(szModule:PAnsiChar):integer; // 0.8.0+ +begin + result:=0; + PluginLink^.CallService(MS_DB_MODULE_DELETE,0,dword(szModule)); +end; + +function DBGetSettingType(hContact:THANDLE;szModule:PAnsiChar;szSetting:PAnsiChar):integer; +var + ldbv:TDBVARIANT; +begin + if DBReadSetting(hContact,szModule,szSetting,@ldbv)=0 then + begin + result:=ldbv._type; + DBFreeVariant(@ldbv); + end + else + result:=DBVT_DELETED; +end; + +begin +end. + diff --git a/delphi/Awkward/utils/hotkeys.pas b/delphi/Awkward/utils/hotkeys.pas new file mode 100644 index 0000000..738bd55 --- /dev/null +++ b/delphi/Awkward/utils/hotkeys.pas @@ -0,0 +1,571 @@ +{Hotkey and timer related functions} +unit hotkeys; + +interface + +uses windows; + +type + AWKHotKeyProc = function(hotkey:integer):integer; + +function AddProc(aproc:AWKHotKeyProc;ahotkey:integer;global:bool=false):integer; overload; +function AddProc(ahotkey:integer;wnd:HWND;aproc:AWKHotKeyProc ):integer; overload; +function AddProc(ahotkey:integer;wnd:HWND;msg:DWORD ):integer; overload; +function DelProc(hotkey:integer ):integer; overload; +function DelProc(hotkey:integer;wnd:HWND):integer; overload; + +procedure InitHotKeys; +procedure FreeHotKeys; + +implementation + +uses messages; + +var + CurThread:THANDLE; + +type + PKBDLLHOOKSTRUCT = ^TKBDLLHOOKSTRUCT; + TKBDLLHOOKSTRUCT = record + vkCode :dword; + scanCode :dword; + flags :dword; + time :dword; + dwExtraInfo:dword; + end; + +const + WH_KEYBOARD_LL = 13; + WM_MYMESSAGE = WM_USER +13; + +// const from commctrl module; +const + HOTKEYF_SHIFT = $01; + HOTKEYF_CONTROL = $02; + HOTKEYF_ALT = $04; + HOTKEYF_EXT = $08; + +const + hkAssigned = 1; + hkGlobal = 2; + hkMessage = 4; +const + kbHook:THANDLE=0; + hiddenwindow:HWND=0; + modifiers:dword=0; +const + PageStep = 10; +type + PHKRec = ^THKRec; + THKRec = record + proc :AWKHotKeyProc; // procedure + flags :integer; // options + handle:THANDLE; // thread or window? + atom :TATOM; // hotkey id + hotkey:integer; // hotkey + end; + PHKRecs = ^THKRecs; + THKRecs = array [0..15] of THKRec; + +const + NumRecs:integer=0; + MaxRecs:integer=10; + hkRecs:pHKRecs=nil; + +//----- simpler version of 'common' function ----- + +const + HexDigitChr: array [0..15] of AnsiChar = ('0','1','2','3','4','5','6','7', + '8','9','A','B','C','D','E','F'); + +function IntToHex(dst:PAnsiChar;Value:cardinal):PAnsiChar; +var + Digits:integer; +begin + dst[8]:=#0; + Digits:=8; + repeat + Dec(Digits); + dst[Digits]:=HexDigitChr[Value and $F]; + Value:=Value shr 4; + until Digits=0; + result:=dst; +end; + +//----- utils ----- + +function GetAtom(hotkey:dword):dword; +const + HKPrefix = 'awk_'; +var + p:array [0..15] of AnsiChar; +begin + lstrcpya(p,HKPrefix); + IntToHex(p+Length(HKPrefix),hotkey); + result:=GlobalAddAtomA(p); +end; + +function HotKeyDlgToHook(w:cardinal):cardinal; register; +asm + movzx ecx,al + xor al,al + test ah,HOTKEYF_ALT + je @L1 + or al,MOD_ALT +@L1: + test ah,HOTKEYF_CONTROL + je @L2 + or al,MOD_CONTROL +@L2: + test ah,HOTKEYF_SHIFT + je @L3 + or al,MOD_SHIFT +@L3: + test ah,HOTKEYF_EXT + je @L4 + or al,MOD_WIN +@L4: + mov ch,al + mov eax,ecx +{ +begin + result:=w and $FF; + if (w and (HOTKEYF_ALT shl 8))<>0 then result:=result or (MOD_ALT shl 8); + if (w and (HOTKEYF_CONTROL shl 8))<>0 then result:=result or (MOD_CONTROL shl 8); + if (w and (HOTKEYF_SHIFT shl 8))<>0 then result:=result or (MOD_SHIFT shl 8); + if (w and (HOTKEYF_EXT shl 8))<>0 then result:=result or (MOD_WIN shl 8); +} +end; + +function HotKeyHookToDlg(w:cardinal):cardinal; register; +asm + movzx ecx,al + xor al,al + test ah,MOD_ALT + je @L1 + or al,HOTKEYF_ALT +@L1: + test ah,MOD_CONTROL + je @L2 + or al,HOTKEYF_CONTROL +@L2: + test ah,MOD_SHIFT + je @L3 + or al,HOTKEYF_SHIFT +@L3: + test ah,MOD_WIN + je @L4 + or al,HOTKEYF_EXT +@L4: + mov ch,al + mov eax,ecx +{ +begin + result:=w and $FF; + if (w and (MOD_ALT shl 8))<>0 then result:=result or (HOTKEYF_ALT shl 8); + if (w and (MOD_CONTROL shl 8))<>0 then result:=result or (HOTKEYF_CONTROL shl 8); + if (w and (MOD_SHIFT shl 8))<>0 then result:=result or (HOTKEYF_SHIFT shl 8); + if (w and (MOD_WIN shl 8))<>0 then result:=result or (HOTKEYF_EXT shl 8); +} +end; + +//----- Hook ----- + +function FindHotkey(keycode:integer;local:boolean):pointer; +var + i:integer; + p:pHKRec; +begin + i:=NumRecs; + p:=pointer(HKRecs); + while i>0 do + begin + dec(i); + with p^ do + begin + if (flags and hkAssigned)<>0 then + begin + if (local xor ((flags and hkGlobal)<>0)) then + begin + if hotkey=keycode then + begin + if handle<>0 then + begin + if GetFocus=handle then + begin + if (flags and hkMessage)<>0 then + begin + PostMessage(handle,dword(@proc),keycode,0); + result:=pointer(-1); + end + else + result:=@proc; + exit; + end; + end + else + begin + result:=@proc; + exit; + end; + end; + end; + end; + end; + inc(p); + end; + result:=nil; +end; + +function wmKeyboard_hook(code:integer;wParam:integer;lParam:longint):longint; stdcall; +var + key:dword; + proc:pointer; +begin + if (code=HC_ACTION) and + (lParam>0) and (LoWord(lParam)=1) then + begin + key:=0; + if (GetKeyState(VK_SHIFT ) and $8000)<>0 then key:=key or (MOD_SHIFT shl 8); + if (GetKeyState(VK_CONTROL) and $8000)<>0 then key:=key or (MOD_CONTROL shl 8); + if (GetKeyState(VK_MENU ) and $8000)<>0 then key:=key or (MOD_ALT shl 8); + if (GetKeyState(VK_LWIN ) and $8000)<>0 then key:=key or (MOD_WIN shl 8); + if (GetKeyState(VK_RWIN ) and $8000)<>0 then key:=key or (MOD_WIN shl 8); +// if (GetKeyState(VK_APPS) and $8000)<>0 then +// if (GetKeyState(VK_SLEEP) and $8000)<>0 then + key:=key or lo(wParam); + proc:=FindHotkey(key,true); + if proc<>nil then + begin + if integer(proc)<>-1 then + PostMessageA(hiddenwindow,WM_MYMESSAGE,key,dword(proc)); + result:=1; + exit; + end; + end; + result:=CallNextHookEx(KbHook,code,wParam,lParam); +end; + +function wmKeyboardLL_hook(code:integer;wParam:integer;lParam:integer):integer; stdcall; +const + lastkey:dword=0; +var + mask:dword; + key:dword; + proc:pointer; +begin + if code=HC_ACTION then + begin + case PKBDLLHOOKSTRUCT(lParam)^.vkCode of + VK_MENU, + VK_LMENU, + VK_RMENU: mask:=MOD_ALT shl 8; + VK_LWIN, + VK_RWIN: mask:=MOD_WIN shl 8; + VK_SHIFT, + VK_LSHIFT, + VK_RSHIFT: mask:=MOD_SHIFT shl 8; + VK_CONTROL, + VK_LCONTROL, + VK_RCONTROL: mask:=MOD_CONTROL shl 8; + else + if (PKBDLLHOOKSTRUCT(lParam)^.flags and 128)=0 then + begin + // local only +// maybe process will better choice? + if //(lastkey=0) and + (CurThread=GetWindowThreadProcessId(GetForegroundWindow,nil)) then + begin + key:=PKBDLLHOOKSTRUCT(lParam)^.vkCode or modifiers; + proc:=FindHotkey(key,true); + if proc<>nil then + begin + lastkey:=PKBDLLHOOKSTRUCT(lParam)^.vkCode; + if integer(proc)<>-1 then + PostMessageA(hiddenwindow,WM_MYMESSAGE,key,dword(proc)); + result:=1; + exit; + end; + end; + end + else if (lastkey<>0) and (lastkey=PKBDLLHOOKSTRUCT(lParam)^.vkCode) then + begin + lastkey:=0; + result :=1; + exit; + end; + mask:=0; + end; + if mask<>0 then + begin + if (PKBDLLHOOKSTRUCT(lParam)^.flags and 128)=0 then + modifiers:=modifiers or mask + else + modifiers:=modifiers and not mask; + end + end; + result:=CallNextHookEx(KbHook,code,wParam,lParam); +end; + +function HiddenWindProc(wnd:HWnd; msg,wParam,lParam:integer):integer; stdcall; +var + key:dword; +begin + if Msg=WM_HOTKEY then + begin + key:=(lParam shr 16)+(Lo(lParam) shl 8); + result:=dword(FindHotKey(key,false)); + if result<>0 then + begin + result:=AWKHotKeyProc(result)(HotkeyHookToDlg(key)); + exit; + end; + end + else if Msg=WM_MYMESSAGE then + begin + result:=AWKHotKeyProc(lParam)(HotkeyHookToDlg(wParam)); + exit; + end; + result:=DefWindowProcA(wnd,msg,wparam,lparam); +end; + +procedure DestroyHiddenWindow; +begin + if hiddenwindow<>0 then + begin + DestroyWindow(hiddenwindow); + hiddenwindow:=0; + end; +end; + +procedure CreateHiddenWindow; +var + wnd:HWND; +begin + if hiddenwindow=0 then + begin + wnd:=CreateWindowExA(0,'STATIC',nil,0, + 1,1,1,1,dword(HWND_MESSAGE),0,hInstance,nil); + if wnd<>0 then + begin + SetWindowLongA(wnd,GWL_WNDPROC,dword(@HiddenWindProc)); + hiddenwindow:=wnd; + end + end +end; +//----- interface ----- + +function CheckTable(ahotkey:integer;global:bool):integer; +var + tmp:pHKRecs; + i:integer; + p:pHKRec; +begin + if HKRecs=nil then + begin + MaxRecs:=PageStep; + GetMem (HKRecs ,MaxRecs*SizeOf(THKRec)); + FillChar(HKRecs^,MaxRecs*SizeOf(THKRec),0); + NumRecs:=0; + end; + // search existing + i:=0; + p:=pointer(HKRecs); + while i0 then + begin + if (p^.hotkey=ahotkey) and + (((p^.flags and hkGlobal)<>0) xor not global) then + break; + end; + inc(p); + inc(i); + end; + //search empty + if i=NumRecs then + begin + i:=0; + p:=pointer(HKRecs); + while i0 do + begin + dec(i); + if ((p^.flags and hkAssigned)<>0) and (p^.handle=0) then + if p^.hotkey=hotkey then + begin + if (p^.flags and hkGlobal)<>0 then + begin + UnregisterHotKey(hiddenwindow,p^.atom); + GlobalDeleteAtom(p^.atom); + end; + p^.flags:=p^.flags and not hkAssigned; + result:=i; + exit; + end; + inc(p); + end; + result:=0; +end; + +function DelProc(hotkey:integer;wnd:HWND):integer; +var + i:integer; + p:pHKRec; +begin + hotkey:=HotKeyDlgToHook(hotkey); //!! + p:=pointer(HKRecs); + i:=NumRecs; + while i>0 do + begin + dec(i); + if (p^.flags and hkAssigned)<>0 then + if (p^.handle=wnd) {and ((p^.flags and hkGlobal)=0)} then + begin + if (hotkey=0) or (hotkey=p^.hotkey) then + begin + p^.flags:=p^.flags and not hkAssigned; + result:=i; + exit; + end; + end; + inc(p); + end; + result:=0; +end; + +procedure InitHotKeys; +begin + MaxRecs:=10; + GetMem(HKRecs,SizeOf(THKRec)*MaxRecs); + FillChar(HKRecs^,SizeOf(THKRec)*MaxRecs,0); + NumRecs:=0; + CreateHiddenWindow; + kbhook:=SetWindowsHookExA(WH_KEYBOARD_LL,@wmKeyboardLL_hook,hInstance,0); + + if KbHook=0 then + KbHook:=SetWindowsHookExA(WH_KEYBOARD,@wmKeyboard_hook,0,GetCurrentThreadId); +end; + +procedure FreeHotKeys; +var + i:integer; + p:pHKRec; +begin + i:=NumRecs; + p:=pointer(HKRecs); + while i>0 do + begin + dec(i); + if (p^.flags and (hkAssigned or hkGlobal))=(hkAssigned or hkGlobal) then + begin + UnregisterHotKey(hiddenwindow,p^.atom); + GlobalDeleteAtom(p^.atom); + end; + inc(p); + end; + DestroyHiddenWindow; + if kbhook<>0 then + UnhookWindowsHookEx(kbhook); + FreeMem(HKRecs); + HKRecs:=nil; + MaxRecs:=0; + NumRecs:=0; +end; + +initialization + CurThread:=GetCurrentThreadId(); +end. \ No newline at end of file diff --git a/delphi/Awkward/utils/ini.pas b/delphi/Awkward/utils/ini.pas new file mode 100644 index 0000000..7c1e50d --- /dev/null +++ b/delphi/Awkward/utils/ini.pas @@ -0,0 +1,857 @@ +unit INI; + +interface + +uses windows; + +{+}function SetStorage(name:PAnsiChar;inINI:boolean):cardinal; +{+}procedure FreeStorage(aHandle:cardinal); + +{+}procedure SetDefaultSection(aHandle:cardinal;name:PAnsiChar); +{+}procedure SetCurrentSection(aHandle:cardinal;sect:PAnsiChar); + +{+}procedure FlushSettings(aHandle:cardinal); +{+}procedure FlushSection(aHandle:cardinal); + +{+}procedure WriteNCInt(aHandle:cardinal;sect:PAnsiChar;param:PAnsiChar;value:integer); +{+}procedure WriteNCStr(aHandle:cardinal;sect:PAnsiChar;param:PAnsiChar;value:PAnsiChar); + +{+}procedure WriteNCStruct(aHandle:cardinal;sect:PAnsiChar;param:PAnsiChar;ptr:pointer;size:integer); +{*}procedure WriteStruct(aHandle:cardinal;param:PAnsiChar;ptr:pointer;size:integer); +{+}function ReadStruct (aHandle:cardinal;param:PAnsiChar;ptr:pointer;size:integer):boolean; + +{+}procedure WriteFlag(aHandle:cardinal;param:PAnsiChar;value:integer); +{+}procedure WriteInt (aHandle:cardinal;param:PAnsiChar;value:integer); +{+}procedure WriteStr (aHandle:cardinal;param:PAnsiChar;value:PWideChar); +procedure WriteAnsiStr(aHandle:cardinal;param:PAnsiChar;value:PAnsiChar); +{+}function ReadFlag(aHandle:cardinal;param:PAnsiChar; default:integer):integer; +{+}function ReadInt (aHandle:cardinal;param:PAnsiChar; default:integer):integer; +procedure ReadStr (aHandle:cardinal;var dst:PWideChar;param:PAnsiChar;default:PWideChar); +procedure ReadAnsiStr(aHandle:cardinal;var dst:PAnsiChar;param:PAnsiChar;default:PAnsiChar); + +procedure WriteSect(aHandle:cardinal;src:PAnsiChar); +procedure ReadSect (aHandle:cardinal;var dst:PAnsiChar); + +{*}procedure ClearSection(aHandle:cardinal); +{+}procedure DeleteParam(aHandle:cardinal;param:PAnsiChar); + +implementation + +uses common,io,m_api,dbsettings; + +type + PStorage = ^TStorage; + TStorage = record + SName :PAnsiChar; + SType :bool; + SHandle :THANDLE; + DefSection:PAnsiChar; + Section :Array [0..127] of AnsiChar; + ParOffset :integer; + Buffer :PAnsiChar; + INIBuffer :PAnsiChar; + end; + PStHeap = ^TStHeap; + TStHeap = array [0..10] of TStorage; + +const + Storage:PStHeap=nil; + NumStorage:cardinal=0; + +type + pbrec=^brec; + brec=record + ptr:PAnsiChar; + handle:cardinal; + end; + +const + DefDefSection:PAnsiChar = 'default'; + +{+}function SetStorage(name:PAnsiChar;inINI:boolean):cardinal; +var + i:integer; + tmp:PStHeap; +begin + if Storage=nil then + begin + mGetMem(Storage,SizeOf(TStorage)); + FillChar(Storage^,SizeOf(TStorage),0); + NumStorage:=1; + result:=0; + end + else + begin + integer(result):=-1; + for i:=0 to NumStorage-1 do + begin + if Storage^[i].SName=nil then // free cell + begin + result:=i; + break; + end; + end; + if integer(result)<0 then + begin + mGetMem(tmp,SizeOf(TStorage)*(NumStorage+1)); + move(Storage^,tmp^,SizeOf(TStorage)*NumStorage); + mFreeMem(Storage); + Storage:=tmp; + FillChar(Storage^[NumStorage],SizeOf(TStorage),0); + result:=NumStorage; + inc(NumStorage); + end + end; + with Storage^[result] do + begin + StrDup(SName,name); + SType:=inINI; + end; +end; + +{+}procedure FreeStorage(aHandle:cardinal); +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + begin + mFreeMem(SName); + mFreeMem(DefSection); + mFreeMem(Buffer); + mFreeMem(INIBuffer); + end; +end; + +{+}procedure WriteNCStruct(aHandle:cardinal;sect:PAnsiChar;param:PAnsiChar;ptr:pointer;size:integer); +var + cws:TDBCONTACTWRITESETTING; + pn:array [0..127] of AnsiChar; + i:integer; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + begin + if (sect=nil) or (sect^=#0) then + sect:=DefSection; + if sect=nil then + sect:=DefDefSection; + WritePrivateProfileStructA(sect,param,ptr,size,SName); + end + else + begin + if (sect<>nil) and (sect^<>#0) then + begin + i:=StrLen(sect); + move(sect^,pn,i); + pn[i]:='/'; + inc(i); + end + else + i:=0; + StrCopy(pn+i,param); + cws.szModule :=SName; + cws.szSetting :=pn; + cws.value._type :=DBVT_BLOB; + cws.value.pbVal :=ptr; + cws.value.cpbVal:=size; + PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING,0,lParam(@cws)); + end +end; + +{*}procedure WriteStruct(aHandle:cardinal;param:PAnsiChar;ptr:pointer;size:integer); +const + hex:array [0..15] of AnsiChar = '0123456789ABCDEF'; +var + lptr:PAnsiChar; + buf,buf1:PAnsiChar; + i:integer; + crc:integer; + cws:TDBCONTACTWRITESETTING; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + begin + mGetMem(buf,(size+1)*2); + crc:=0; + buf1:=buf; + for i:=0 to size-1 do + begin + inc(crc,PByte(ptr)^); + buf1^ :=hex[pbyte(ptr)^ shr 4]; + (buf1+1)^:=hex[pbyte(ptr)^ and $0F]; + inc(buf1,2); + inc(pbyte(ptr)); + end; + buf1^ :=hex[(crc and $FF) shr 4]; + (buf1+1)^:=hex[(crc and $0F)]; + + StrCat(Buffer,param); + lptr:=StrEnd(Buffer); + lptr^:='='; + inc(lptr); + move(buf^,lptr^,(size+1)*2); + mFreeMem(buf); + inc(lptr,(size+1)*2); + lptr^ :=#13; + (lptr+1)^:=#10; + (lptr+2)^:=#0; + end + else + begin + StrCopy(Section+ParOffset,param); + cws.szModule :=SName; + cws.szSetting :=Section; + cws.value._type :=DBVT_BLOB; + cws.value.pbVal :=ptr; + cws.value.cpbVal:=size; + PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING,0,lParam(@cws)); + end +end; + +{+}function ReadStruct(aHandle:cardinal;param:PAnsiChar;ptr:pointer;size:integer):boolean; +var + dbv:TDBVariant; +begin + if aHandle>=NumStorage then + begin + result:=false; + exit; + end; + with Storage^[aHandle] do + if SType then + begin + result:=GetPrivateProfileStructA(Section,param,ptr,size,SName); + end + else + begin + dbv._type:=DBVT_BLOB; + dbv.pbVal:=nil; + StrCopy(Section+ParOffset,param); + if (DBReadSetting(0,SName,Section,@dbv)=0) and + (dbv.pbVal<>nil) and (dbv.cpbVal=size) then + begin + move(dbv.pbVal^,ptr^,size); + DBFreeVariant(@dbv); + result:=true; + end + else + result:=false; + end +end; + +{+}procedure WriteNCInt(aHandle:cardinal;sect:PAnsiChar;param:PAnsiChar;value:integer); +var + pn:array [0..127] of AnsiChar; + i:integer; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if Stype then + begin + if (sect=nil) or (sect^=#0) then + sect:=DefSection; + if sect=nil then + sect:=DefDefSection; + WritePrivateProfileStringA(sect,param,IntToStr(pn,value),SName); + end + else + begin + if (sect<>nil) and (sect^<>#0) then + begin + i:=StrLen(sect); + move(sect^,pn,i); + pn[i]:='/'; + inc(i); + end + else + i:=0; + StrCopy(pn+i,param); + DBWriteDWord(0,SName,pn,value) + end +end; + +{+}procedure WriteNCStr(aHandle:cardinal;sect:PAnsiChar;param:PAnsiChar;value:PAnsiChar); +var + pn:array [0..127] of AnsiChar; + i:integer; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + begin + if (sect=nil) or (sect^=#0) then + sect:=DefSection; + if sect=nil then + sect:=DefDefSection; + WritePrivateProfileStringA(sect,param,value,SName); + end + else + begin + if (sect<>nil) and (sect^<>#0) then + begin + i:=StrLen(sect); + move(sect^,pn,i); + pn[i]:='/'; + inc(i); + end + else + i:=0; + StrCopy(pn+i,param); + DBWriteString(0,SName,pn,value); + end +end; + +{+}procedure SetDefaultSection(aHandle:cardinal;name:PAnsiChar); +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + begin + mFreeMem(DefSection); + StrDup(DefSection,name); + end; +end; + +{+}procedure SetCurrentSection(aHandle:cardinal;sect:PAnsiChar); +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + begin + if sect=nil then + sect:=DefSection; + if sect=nil then + sect:=''; + if SType then + begin + if (sect=nil) or (sect^=#0) then + sect:=DefDefSection; + StrCopy(Section,sect); + mGetMem(Buffer,16384); + Buffer^ :=#13; + (Buffer+1)^:=#10; + (Buffer+2)^:=#0; + end + else + begin + if sect<>nil then + begin + StrCopy(Section,sect); + ParOffset:=StrLen(Section); + Section[ParOffset]:='/'; + inc(ParOffset); + end + else + ParOffset:=0; + end + end; +end; + +{+}procedure FlushSettings(aHandle:cardinal); +var + size:integer; + ptr:PAnsiChar; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + begin + if SType then + begin + if INIBuffer=nil then + exit; + ptr:=INIBuffer+1; + size:=StrLen(ptr); + seek(SHandle,0); + BlockWrite(SHandle,ptr^,size); + SetEndOfFile(SHandle); + mFreeMem(INIBuffer); + CloseHandle(SHandle); + end; + end; +end; + +{+}procedure FlushSection(aHandle:cardinal); +var + size,i:integer; + sect:array [0..127] of AnsiChar; + ptr1,ptr:PAnsiChar; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + begin + if INIBuffer=nil then + begin + mGetMem(INIBuffer,32768); + INIBuffer[0]:=#10; + SHandle:=Reset(SName); + if dword(SHandle)=INVALID_HANDLE_VALUE then + INIBuffer[1]:=#0 + else + begin + size:=FileSize(SHandle); + INIBuffer[size+1]:=#0; + BlockRead(SHandle,(INIBuffer+1)^,size); + CloseHandle(SHandle); + end; + SHandle:=ReWrite(SName); + end; + // construct section name + sect[0]:=#10; + sect[1]:='['; + size:=StrLen(Section); + move(Section,sect[2],size); + sect[size+2]:=']'; + sect[size+3]:=#0; + // search section + ptr:=StrPos(INIBuffer,sect); + // delete section + if ptr<>nil then + begin + ptr1:=ptr; +//!! inc(ptr); + while (ptr^<>#0) and ((ptr^<>#10) or ((ptr+1)^<>'[')) do inc(ptr); + if ptr^<>#0 then + StrCopy(ptr1,ptr+1) + else + ptr1^:=#0; + end; + // append section + if (Buffer<>nil) and (StrLen(Buffer)>0) then + begin + i:=StrLen(INIBuffer); + if INIBuffer[i-1]<>#10 then + begin + INIBuffer[i] :=#13; + INIBuffer[i+1]:=#10; + inc(i,2); + end; + StrCopy(INIBuffer+i,sect+1); + StrCat(INIBuffer,Buffer); + end; + mFreeMem(Buffer); + end; +end; + +{+}procedure WriteFlag(aHandle:cardinal;param:PAnsiChar;value:integer); +var + ptr:PAnsiChar; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + begin + StrCat(Buffer,param); + ptr:=StrEnd(Buffer); + ptr^:='='; + (ptr+1)^:=CHR((value and 1)+ORD('0')); + inc(ptr,2); + ptr^ :=#13; + (ptr+1)^:=#10; + (ptr+2)^:=#0; + end + else + begin + StrCopy(Section+ParOffset,param); + DBWriteByte(0,SName,Section,value) + end; +end; + +{+}procedure WriteInt(aHandle:cardinal;param:PAnsiChar;value:integer); +var + ptr:PAnsiChar; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + begin + StrCat(Buffer,param); + ptr:=StrEnd(Buffer); + ptr^:='='; + IntToStr(ptr+1,value); + ptr:=StrEnd(Buffer); + ptr^ :=#13; + (ptr+1)^:=#10; + (ptr+2)^:=#0; + end + else + begin + StrCopy(Section+ParOffset,param); + DBWriteDWord(0,SName,Section,value) + end; +end; + +procedure WriteStrInt(aHandle:cardinal;param:PAnsiChar;value:pointer;wide:bool); +var + buf:array [0..2047] of AnsiChar; + ptr:PAnsiChar; + lval:PAnsiChar; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + begin + StrCat(Buffer,param); + ptr:=StrEnd(Buffer); + ptr^:='='; + inc(ptr); + if (value<>nil) then + begin + buf[0]:=#0; + if wide then + begin + if PWideChar(value)^<>#0 then + begin + WideToUTF8(value,lval); + StrCopy(buf,lval,SizeOf(buf)-1); + mFreeMem(lval); + end + end + else if PAnsiChar(value)^<>#0 then + StrCopy(buf,value,SizeOf(buf)-1); + if buf[0]<>#0 then + begin + Escape(buf); + StrCopy(ptr,buf); + ptr:=StrEnd(Buffer); + end; + end; + ptr^ :=#13; + (ptr+1)^:=#10; + (ptr+2)^:=#0; + end + else + begin + StrCopy(Section+ParOffset,param); + if wide then + DBWriteUnicode(0,SName,Section,value) + else + DBWriteString(0,SName,Section,value) + end; +end; + +{+}procedure WriteStr(aHandle:cardinal;param:PAnsiChar;value:PWideChar); +begin + WriteStrInt(aHandle,param,value,true); +end; + +{+}procedure WriteAnsiStr(aHandle:cardinal;param:PAnsiChar;value:PAnsiChar); +begin + WriteStrInt(aHandle,param,value,false); +end; + +{+}function ReadFlag(aHandle:cardinal; param:PAnsiChar; default:integer):integer; +begin + if aHandle>=NumStorage then + begin + result:=default; + exit; + end; + with Storage^[aHandle] do + if SType then + begin + result:=GetPrivateProfileIntA(Section,param,default,SName) + end + else + begin + StrCopy(Section+ParOffset,param); + result:=DBReadByte(0,SName,Section,default) + end; +end; + +{+}function ReadInt(aHandle:cardinal; param:PAnsiChar; default:integer):integer; +begin + if aHandle>=NumStorage then + begin + result:=default; + exit; + end; + with Storage^[aHandle] do + if SType then + begin + result:=GetPrivateProfileIntA(Section,param,default,SName) + end + else + begin + StrCopy(Section+ParOffset,param); + result:=DBReadDWord(0,SName,Section,default) + end; +end; + +procedure ReadStrInt(aHandle:cardinal;var dst;param:PAnsiChar;default:pointer;wide:bool); + + function EnumSettingsProc(const szSetting:PAnsiChar;lParam:LPARAM):int; cdecl; + var + p:pbrec; + i:integer; + begin + p:=pbrec(lparam); + if StrCmp(Storage^[p^.handle].Section,szSetting,Storage^[p^.handle].ParOffset)=0 then + begin + i:=StrLen(szSetting)+1; + move(szSetting^,p^.ptr^,i); + inc(p^.ptr,i); + end; + result:=0; + end; + +var + buf:array [0..4095] of AnsiChar; + p:brec; + ces:TDBCONTACTENUMSETTINGS; + def:PAnsiChar; + i:integer; +begin + if aHandle>=NumStorage then + begin + if wide then + StrDupW(pWideChar(dst),pWideChar(default)) + else + StrDup(PAnsiChar(dst),PAnsiChar(default)); + exit; + end; + with Storage^[aHandle] do + if SType then + begin + if wide then + begin + if default=nil then + StrDup(def,'') + else + WideToUTF8(default,def); + end + else + begin + if default=nil then + def:='' + else + def:=default; + end; + i:=GetPrivateProfileStringA(Section,param,def,buf,4095,SName)+1; + mFreeMem(def); + if param<>nil then + begin + if buf[0]<>#0 then + begin + Unescape(buf); + if wide then + UTF8ToWide(buf,pWideChar(dst)) + else + StrDup(PAnsiChar(dst),buf); + end + else + PAnsiChar(dst):=nil; + end + else //!! full section + begin + mGetMem(dst,i); + move(buf,PAnsiChar(dst)^,i); + buf[i-1]:=#0; + end; + end + else + begin + if param<>nil then + begin + StrCopy(Section+ParOffset,param); + if wide then + pWideChar(dst):=DBReadUnicode(0,SName,Section,pWideChar(default)) + else + PAnsiChar(dst):=DBReadString(0,SName,Section,PAnsiChar(default)); + end + else + begin + p.ptr:=@buf; + p.handle:=aHandle; + FillChar(buf,SizeOf(buf),0); + ces.pfnEnumProc:=@EnumSettingsProc; + ces.lParam :=dword(@p); + ces.szModule :=SName; + ces.ofsSettings:=0; + PluginLink^.CallService(MS_DB_CONTACT_ENUMSETTINGS,0,dword(@ces)); + mGetMem(dst,p.ptr-@buf+1); + move(buf,PAnsiChar(dst)^,p.ptr-@buf+1); + end; + end; +end; + +procedure ReadStr(aHandle:cardinal;var dst:PWideChar;param:PAnsiChar;default:PWideChar); +begin + ReadStrInt(aHandle,dst,param,default,true); +end; + +procedure ReadAnsiStr(aHandle:cardinal;var dst:PAnsiChar;param:PAnsiChar;default:PAnsiChar); +begin + ReadStrInt(aHandle,dst,param,default,false); +end; + +{*}procedure ClearSection(aHandle:cardinal); + + function EnumSettingsProc(const szSetting:PAnsiChar;lParam:LPARAM):int; cdecl; + var + db:TDBCONTACTGETSETTING; + begin + with Storage^[lParam] do + begin + db.szModule:=SName; + StrCopy(Section+ParOffset,szSetting); + db.szSetting:=Section; + end; + PluginLink^.CallService(MS_DB_CONTACT_DELETESETTING,0,dword(@db)); + result:=0; + end; + +var + ces:TDBCONTACTENUMSETTINGS; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + WritePrivateProfileStringA(Section,nil,nil,SName) + else + begin + ces.pfnEnumProc:=@EnumSettingsProc; + ces.lParam :=aHandle; + ces.szModule :=SName; + ces.ofsSettings:=0; + PluginLink^.CallService(MS_DB_CONTACT_ENUMSETTINGS,0,dword(@ces)); + end; +end; + +{*}procedure WriteSect(aHandle:cardinal;src:PAnsiChar); +var + p:PAnsiChar; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + if SType then + WritePrivateProfileSectionA(Section,src,SName) + else + begin + ClearSection(aHandle); + while src^<>#0 do + begin + // write as strings + p:=src; + while src^<>'=' do inc(src); + inc(src); + DBWriteString(0,SName,p,src); + while src^<>#0 do inc(src); + inc(src); + end; + end; +end; + +procedure ReadSect(aHandle:cardinal;var dst:PAnsiChar); + + function EnumSettingsProc(const szSetting:PAnsiChar;lParam:LPARAM):int; cdecl; + var + dbv:TDBVariant; + i:integer; + p:pbrec; + buf:array [0..31] of AnsiChar; + begin + result:=1; + + p:=pbrec(lparam); + if (DBReadSetting(0,Storage^[p^.handle].Section,szSetting,@dbv)=0) then + begin + i:=StrLen(szSetting); + move(szSetting^,p^.ptr^,i); + inc(p^.ptr,i); + p^.ptr^:='='; + case dbv._type of + DBVT_ASCIIZ: begin + if dbv.szVal.a<>nil then + begin + i:=StrLen(dbv.szVal.a)+1; + move(dbv.szVal.a^,(p^.ptr+1)^,i); + DBFreeVariant(@dbv); + end + end; + DBVT_BYTE,DBVT_WORD,DBVT_DWORD: begin + case dbv._type of + DBVT_BYTE : i:=dbv.bVal; + DBVT_WORD : i:=dbv.wVal; + DBVT_DWORD: i:=dbv.dVal; + end; + i:=StrLen(IntToStr(buf,i))+1; + move(buf,(p^.ptr+1)^,i); + end; + else + exit; + end; + inc(p^.ptr,i{+1}); + end; + end; + +var + buf:array [0..16383] of AnsiChar; + p:brec; + ces:TDBCONTACTENUMSETTINGS; + i:integer; +begin + if aHandle>=NumStorage then + begin + dst:=nil; + exit; + end; + with Storage^[aHandle] do + begin + if SType then + begin + i:=GetPrivateProfileSectionA(Section,buf,SizeOf(buf),SName)+1; + end + else + begin + p.ptr:=@buf; + p.handle:=aHandle; + FillChar(buf,SizeOf(buf),0); + + ces.pfnEnumProc:=@EnumSettingsProc; + ces.lParam :=dword(@p); + ces.szModule :=SName; + ces.ofsSettings:=0; + PluginLink^.CallService(MS_DB_CONTACT_ENUMSETTINGS,0,dword(@ces)); + i:=p.ptr-@buf+1; + end; + mGetMem(dst,i); + move(buf,dst^,i); + buf[i-1]:=#0; + end; +end; + +{+}procedure DeleteParam(aHandle:cardinal;param:PAnsiChar); +var + db:TDBCONTACTGETSETTING; +begin + if aHandle>=NumStorage then + exit; + with Storage^[aHandle] do + begin + if SType then + WritePrivateProfileStringA(Section,param,nil,SName) + else + begin + StrCopy(Section+ParOffset,param); + db.szModule :=SName; + db.szSetting:=Section; + PluginLink^.CallService(MS_DB_CONTACT_DELETESETTING,0,dword(@db)); + end; + end; +end; + +end. diff --git a/delphi/Awkward/utils/io.pas b/delphi/Awkward/utils/io.pas new file mode 100644 index 0000000..aedbfeb --- /dev/null +++ b/delphi/Awkward/utils/io.pas @@ -0,0 +1,249 @@ +unit IO; + +interface +uses windows; + +function Reset (fname:PWideChar):THANDLE; overload; +function Reset (fname:PAnsiChar):THANDLE; overload; +function ReWrite(fname:PWideChar):THANDLE; overload; +function ReWrite(fname:PAnsiChar):THANDLE; overload; +function Append (fname:PWideChar):THANDLE; overload; +function Append (fname:PAnsiChar):THANDLE; overload; + +function GetFSize(name:PWideChar):dword; overload; +function GetFSize(name:PAnsiChar):dword; overload; +function FileExists(fname:PAnsiChar):Boolean; overload; +function FileExists(fname:PWideChar):Boolean; overload; + +function Skip(f:THANDLE;count:integer):integer; +function Seek(f:THANDLE;pos:integer):integer; +function FilePos(f:THANDLE):dword; +function FileSize(f:THANDLE):dword; +function Eof(f:THANDLE):boolean; + +function BlockRead (f:THANDLE;var buf;size:integer):dword; +function BlockWrite(f:THANDLE;var buf;size:integer):dword; + +function ForceDirectories(path:PAnsiChar):boolean; overload; +function ForceDirectories(path:PWideChar):boolean; overload; +function DirectoryExists(Directory:PAnsiChar):Boolean; overload; +function DirectoryExists(Directory:PWideChar):Boolean; overload; + +implementation + +function Reset(fname:PWideChar):THANDLE; +begin + result:=CreateFileW(fname,GENERIC_READ,FILE_SHARE_READ+FILE_SHARE_WRITE,nil,OPEN_EXISTING,0,0); +end; + +function Reset(fname:PAnsiChar):THANDLE; +begin + result:=CreateFileA(fname,GENERIC_READ,FILE_SHARE_READ+FILE_SHARE_WRITE,nil,OPEN_EXISTING,0,0); +end; + +function Append(fname:PWideChar):THANDLE; +begin + result:=CreateFileW(fname,GENERIC_WRITE,FILE_SHARE_READ,nil,OPEN_ALWAYS,0,0); + SetFilePointer(result,0,nil,FILE_END); +end; + +function Append(fname:PAnsiChar):THANDLE; +begin + result:=CreateFileA(fname,GENERIC_WRITE,FILE_SHARE_READ,nil,OPEN_ALWAYS,0,0); + SetFilePointer(result,0,nil,FILE_END); +end; + +function ReWrite(fname:PWideChar):THANDLE; overload; +begin + result:=CreateFileW(fname,GENERIC_WRITE,FILE_SHARE_READ,nil,CREATE_ALWAYS,0,0); +end; + +function ReWrite(fname:PAnsiChar):THANDLE; overload; +begin + result:=CreateFileA(fname,GENERIC_WRITE,FILE_SHARE_READ,nil,CREATE_ALWAYS,0,0); +end; + +function Skip(f:THANDLE;count:integer):integer; +begin + result:=SetFilePointer(f,count,nil,FILE_CURRENT); +end; + +function Eof(f:THANDLE):boolean; +begin + result:=FilePos(f)>=FileSize(f); +end; + +function Seek(f:THANDLE;pos:integer):integer; +begin + result:=SetFilePointer(f,pos,nil,FILE_BEGIN); +end; + +function FilePos(f:THANDLE):dword; +begin + result:=SetFilePointer(f,0,nil,FILE_CURRENT); +end; + +function FileSize(f:THANDLE):dword; +begin + result:=GetFileSize(f,nil); +end; + +function BlockRead(f:THANDLE;var buf;size:integer):dword; +begin + ReadFile(f,buf,size,result,nil); +end; + +function BlockWrite(f:THANDLE;var buf;size:integer):dword; +begin + WriteFile(f,buf,size,result,nil); +end; + +function GetFSize(name:PWideChar):dword; +var + lRec:WIN32_FIND_DATAW; + h:THANDLE; +begin + h:=FindFirstFileW(name,lRec); + if h=THANDLE(INVALID_HANDLE_VALUE) then + result:=0 + else + begin + result:=lRec.nFileSizeLow; + FindClose(h); + end; +end; + +function GetFSize(name:PAnsiChar):dword; +var + lRec:WIN32_FIND_DATAA; + h:THANDLE; +begin + h:=FindFirstFileA(name,lRec); + if h=THANDLE(INVALID_HANDLE_VALUE) then + result:=0 + else + begin + result:=lRec.nFileSizeLow; + FindClose(h); + end; +end; + +function ForceDirectories(path:PAnsiChar):boolean; +var + p,pc:PAnsiChar; + i:cardinal; + c:AnsiChar; +begin + result:=true; + if DirectoryExists(path) then exit; + if (path<>nil) and (path^<>#0) then + begin + i:=lstrlena(path)+1; + GetMem(pc,i); + move(path^,pc^,i); + p:=pc; + if (p^ in ['A'..'Z','a'..'z']) and (p[1]=':') then inc(p,2); + if p^ in ['/','\'] then inc(p); + c:=#0; + while p^<>#0 do + begin + c:=' '; + if (p^ in ['/','\']) and (p[1]<>#0) then + begin + c:=p^; + p^:=#0; + if not CreateDirectoryA(pc,nil) then + begin + if GetLastError<>ERROR_ALREADY_EXISTS then + begin + result:=false; + FreeMem(pc); + exit; + end; + end; + p^:=c; + end; + inc(p); + end; + if (c<>#0) and (c=' ') then + if not CreateDirectoryA(pc,nil) then + result:=false; + FreeMem(pc); + end; +end; + +function ForceDirectories(path:PWideChar):boolean; +var + p,pc:PWideChar; + i:cardinal; + c:WideChar; +begin + result:=true; + if DirectoryExists(path) then exit; + if (path<>nil) and (path^<>#0) then + begin + i:=(lstrlenw(path)+1)*SizeOf(WideChar); + GetMem(pc,i); + move(path^,pc^,i); + p:=pc; + if (((p^>='A') and (p^<='Z')) or ((p^>='a') and (p^<='z'))) and (p[1]=':') then inc(p,2); + if (p^='/') or (p^='\') then inc(p); + c:=#0; + while p^<>#0 do + begin + c:=' '; + if ((p^='/') or (p^='\')) and (p[1]<>#0) then + begin + c:=p^; + p^:=#0; + if not CreateDirectoryW(pc,nil) then + if GetLastError<>ERROR_ALREADY_EXISTS then + begin + result:=false; + FreeMem(pc); + exit; + end; + p^:=c; + end; + inc(p); + end; + if (c<>#0) and (c=' ') then + if not CreateDirectoryW(pc,nil) then + result:=false; + FreeMem(pc); + end; +end; + +function DirectoryExists(Directory:PAnsiChar):Boolean; +var + Code: Integer; +begin + Code := GetFileAttributesA(Directory); + Result := (Code<>-1) and ((Code and FILE_ATTRIBUTE_DIRECTORY)<>0); +end; + +function DirectoryExists(Directory:PWideChar):Boolean; +var + Code: Integer; +begin + Code := GetFileAttributesW(Directory); + Result := (Code<>-1) and ((Code and FILE_ATTRIBUTE_DIRECTORY)<>0); +end; + +function FileExists(fname:PAnsiChar):Boolean; +var + Code: Integer; +begin + Code := GetFileAttributesA(fname); + Result := (Code<>-1) and ((Code and FILE_ATTRIBUTE_DIRECTORY)=0); +end; + +function FileExists(fname:PWideChar):Boolean; +var + Code: Integer; +begin + Code := GetFileAttributesW(fname); + Result := (Code<>-1) and ((Code and FILE_ATTRIBUTE_DIRECTORY)=0); +end; + +end. diff --git a/delphi/Awkward/utils/mirutils.pas b/delphi/Awkward/utils/mirutils.pas new file mode 100644 index 0000000..efca1fe --- /dev/null +++ b/delphi/Awkward/utils/mirutils.pas @@ -0,0 +1,1026 @@ +{$Include compilers.inc} +unit mirutils; + +interface + +uses windows,m_api; + +function ConvertFileName(src:pAnsiChar;hContact:THANDLE=0):pAnsiChar; overload; +function ConvertFileName(src:pWideChar;hContact:THANDLE=0):pWideChar; overload; +function ConvertFileName(src:pAnsiChar;dst:pAnsiChar;hContact:THANDLE=0):pAnsiChar; overload; +function ConvertFileName(src:pWideChar;dst:pWideChar;hContact:THANDLE=0):pWideChar; overload; + +function RegisterSingleIcon(resname,ilname,descr,group:PAnsiChar):int; +procedure ShowPopupW(text:pWideChar;title:pWideChar=nil); +function GetAddonFileName(prefix,altname,path:PAnsiChar;ext:PAnsiChar):PAnsiChar; +function TranslateA2W(sz:PAnsiChar):PWideChar; +function MirandaCP:integer; + +function isVarsInstalled:bool; +function ParseVarString(astr:pAnsiChar;aContact:THANDLE=0;extra:pAnsiChar=nil):pAnsiChar; overload; +function ParseVarString(astr:pWideChar;aContact:THANDLE=0;extra:pWideChar=nil):pWideChar; overload; +function ShowVarHelp(dlg:HWND;id:integer=0):integer; + +function IsChat(hContact:THANDLE):bool; +procedure SendToChat(hContact:THANDLE;pszText:PWideChar); + +function SetCListSelContact(hContact:THANDLE):THANDLE; +function GetCListSelContact:THANDLE; {$IFDEF DELPHI10_UP}inline;{$ENDIF} +function GetContactProtoAcc(hContact:THANDLE):PAnsiChar; +function IsMirandaUser(hContact:THANDLE):integer; // >0=Miranda; 0=Not miranda; -1=unknown +procedure ShowContactDialog(hContact:THANDLE;DblClk:boolean=true;anystatus:boolean=true); +function FindContactHandle(proto:pAnsiChar;const dbv:TDBVARIANT;is_chat:boolean=false):THANDLE; +function WndToContact(wnd:hwnd):integer; overload; +function WndToContact:integer; overload; +function GetContactStatus(hContact:THANDLE):integer; +// -2 - deleted account, -1 - disabled account, 0 - hidden +// 1 - metacontact, 2 - submetacontact, positive - active +function IsContactActive(hContact:THANDLE;var proto:pAnsiChar):integer; overload; +function IsContactActive(hContact:THANDLE):integer; overload; + +function CreateGroupW(name:pWideChar;hContact:THANDLE):integer; +function CreateGroup (name:pAnsiChar;hContact:THANDLE):integer; +function MakeGroupMenu(idxfrom:integer=100):HMENU; +function GetNewGroupName(parent:HWND):pWideChar; + +const + HKMT_CORE = 1; + HKMT_HOTKEYPLUS = 2; + HKMT_HK = 3; + HKMT_HKSERVICE = 4; + +function DetectHKManager:dword; + +const + MAX_REDIRECT_RECURSE = 4; + +function GetFile(url:PAnsiChar;save_file:PAnsiChar; + hNetLib:THANDLE=0;recurse_count:integer=0):bool; overload; +// next is just wrapper +function GetFile(url:PWideChar;save_file:PWideChar; + hNetLib:THANDLE=0;recurse_count:integer=0):bool; overload; + +function GetProxy(hNetLib:THANDLE):PAnsiChar; +function LoadImageURL(url:pAnsiChar;size:integer=0):HBITMAP; + +implementation + +uses dbsettings,common,io,syswin,freeimage,kol; + +function ConvertFileName(src:pWideChar;dst:pWideChar;hContact:THANDLE=0):pWideChar; overload; +var + pc,pc1:pWideChar; + dat:TREPLACEVARSDATA; +begin + result:=dst; + dst^:=#0; + if (src<>nil) and (src^<>#0) then + begin + pc:=nil; + if PluginLink^.ServiceExists(MS_UTILS_REPLACEVARS)<>0 then + begin + FillChar(dat,SizeOf(TREPLACEVARSDATA),0); + dat.cbSize:=SizeOf(TREPLACEVARSDATA); + dat.dwflags:=RVF_UNICODE; + pc:=pWideChar(PluginLink^.CallService(MS_UTILS_REPLACEVARS,dword(src),dword(@dat))); + end; + if isVarsInstalled then + begin + if pc<>nil then src:=pc; + pc1:=pc; + pc:=ParseVarString(src,hContact); + if pc1<>nil then mFreeMem(pc1); + end; + if pc<>nil then src:=pc; + PluginLink^.CallService(MS_UTILS_PATHTOABSOLUTEW,dword(src),dword(dst)); + if pc<>nil then mFreeMem(pc); + end; +end; + +function ConvertFileName(src:pWideChar;hContact:THANDLE=0):pWideChar; overload; +var + buf1:array [0..511] of WideChar; +begin + if (src<>nil) and (src^<>#0) then + StrDupW(result,ConvertFileName(src,buf1,hContact)) + else + result:=nil; +end; + +function ConvertFileName(src:pAnsiChar;dst:pAnsiChar;hContact:THANDLE=0):pAnsiChar; overload; +var + pc,pc1:pAnsiChar; + dat:TREPLACEVARSDATA; +begin + result:=dst; + dst^:=#0; + if (src<>nil) and (src^<>#0) then + begin + pc:=nil; + if PluginLink^.ServiceExists(MS_UTILS_REPLACEVARS)<>0 then + begin + FillChar(dat,SizeOf(TREPLACEVARSDATA),0); + dat.cbSize:=SizeOf(TREPLACEVARSDATA); + pc:=pAnsiChar(PluginLink^.CallService(MS_UTILS_REPLACEVARS,dword(src),dword(@dat))); + end; + if isVarsInstalled then + begin + if pc<>nil then src:=pc; + pc1:=pc; + pc:=ParseVarString(src,hContact); + if pc1<>nil then mFreeMem(pc1); + end; + if pc<>nil then src:=pc; + PluginLink^.CallService(MS_UTILS_PATHTOABSOLUTE,dword(src),dword(dst)); + if pc<>nil then mFreeMem(pc); + end; +end; + +function ConvertFileName(src:pAnsiChar;hContact:THANDLE=0):pAnsiChar; overload; +var + buf1:array [0..511] of AnsiChar; +begin + if (src<>nil) and (src^<>#0) then + StrDup(result,ConvertFileName(src,buf1,hContact)) + else + result:=nil; +end; + +const + IsVars:integer=-1; + MirCP:integer=-1; +const + HKManager:integer=-1; + +function MirandaCP:integer; +begin + if MirCP<0 then + MirCP:=CallService(MS_LANGPACK_GETCODEPAGE,0,0); + result:=MirCP; +end; + +function IsChat(hContact:THANDLE):bool; +begin + result:=DBReadByte(hContact, + PAnsiChar(CallService(MS_PROTO_GETCONTACTBASEPROTO,hContact,0)), + 'ChatRoom',0)=1; +end; + +function isVarsInstalled:bool; +begin + if IsVars<0 then + IsVars:=PluginLink^.ServiceExists(MS_VARS_FORMATSTRING); + result:=IsVars<>0; +end; + +function ParseVarString(astr:pAnsiChar;aContact:THANDLE=0;extra:pAnsiChar=nil):pAnsiChar; +var + tfi:TFORMATINFO; + tmp:pAnsiChar; +begin + if isVarsInstalled then + begin + FillChar(tfi,SizeOf(tfi),0); + with tfi do + begin + cbSize :=SizeOf(TFORMATINFO); + szFormat.a :=astr; + szExtraText.a:=extra; + hContact :=aContact; + end; + tmp:=pointer(CallService(MS_VARS_FORMATSTRING,dword(@tfi),0)); + StrDup(result,tmp); + PluginLink^.CallService(MS_VARS_FREEMEMORY,int(tmp),0); + end + else + begin + StrDup(result,astr); + end; +end; + +function ParseVarString(astr:pWideChar;aContact:THANDLE=0;extra:pWideChar=nil):pWideChar; +var + tfi:TFORMATINFO; + tmp:pWideChar; +begin + if isVarsInstalled then + begin + FillChar(tfi,SizeOf(tfi),0); + with tfi do + begin + cbSize :=SizeOf(TFORMATINFO); + flags :=FIF_UNICODE; + szFormat.w :=astr; + szExtraText.w:=extra; + hContact :=aContact; + end; + tmp:=pointer(CallService(MS_VARS_FORMATSTRING,dword(@tfi),0)); + StrDupW(result,tmp); + PluginLink^.CallService(MS_VARS_FREEMEMORY,int(tmp),0); + end + else + begin + StrDupW(result,astr); + end; +end; + +function ShowVarHelp(dlg:HWND;id:integer=0):integer; +var + vhi:TVARHELPINFO; +begin + FillChar(vhi,SizeOf(vhi),0); + with vhi do + begin + cbSize:=SizeOf(vhi); + if id=0 then + flags:=VHF_NOINPUTDLG + else + begin + flags :=VHF_FULLDLG or VHF_SETLASTSUBJECT; + hwndCtrl:=GetDlgItem(dlg,id); + end; + end; + result:=PluginLink^.CallService(MS_VARS_SHOWHELPEX,dlg,dword(@vhi)); +end; + +function DetectHKManager:dword; +begin + if HKManager<0 then + begin + with PluginLink^ do + if ServiceExists('CoreHotkeys/Register' )<>0 then HKManager:=HKMT_CORE + else if ServiceExists('HotkeysPlus/Add' )<>0 then HKManager:=HKMT_HOTKEYPLUS + else if ServiceExists('HotKey/CatchHotkey' )<>0 then HKManager:=HKMT_HK + else if ServiceExists('HotkeysService/RegisterItem')<>0 then HKManager:=HKMT_HKSERVICE + else HKManager:=0; + end; + result:=HKManager; +// else if (CallService(MS_SYSTEM_GETVERSION,0,0) and $FFFF0000)>=$00080000 then // core +end; + +procedure ShowPopupW(text:pWideChar;title:pWideChar=nil); +var + ppdu:TPOPUPDATAW; +begin + FillChar(ppdu,SizeOf(TPOPUPDATAW),0); + if CallService(MS_POPUP_ISSECONDLINESHOWN,0,0)<>0 then + begin + StrCopyW(ppdu.lpwzText,text,MAX_SECONDLINE-1); + if title<>nil then + StrCopyW(ppdu.lpwzContactName,title,MAX_CONTACTNAME-1) + else + ppdu.lpwzContactName[0]:=' '; + end + else + begin + StrCopyW(ppdu.lpwzContactName,text,MAX_CONTACTNAME-1); + ppdu.lpwzText[0]:=' '; + end; + PluginLink^.CallService(MS_POPUP_ADDPOPUPW,DWORD(@ppdu),APF_NO_HISTORY); +end; + +function TranslateA2W(sz:PAnsiChar):PWideChar; +var + tmp:pWideChar; +begin + mGetMem(tmp,(StrLen(sz)+1)*SizeOf(WideChar)); + Result:=PWideChar(PluginLink^.CallService(MS_LANGPACK_TRANSLATESTRING,LANG_UNICODE, + lParam(FastAnsiToWideBuf(sz,tmp)))); + if Result<>tmp then + begin + StrDupW(Result,Result); + mFreeMem(tmp); + end; +end; + +function GetContactProtoAcc(hContact:THANDLE):PAnsiChar; +begin + if PluginLink^.ServiceExists(MS_PROTO_GETCONTACTBASEACCOUNT)<>0 then + result:=PAnsiChar(CallService(MS_PROTO_GETCONTACTBASEACCOUNT,hContact,0)) + else + result:=PAnsiChar(CallService(MS_PROTO_GETCONTACTBASEPROTO,hContact,0)); +end; + +function IsMirandaUser(hContact:THANDLE):integer; // >0=Miranda; 0=Not miranda; -1=unknown +var + sz:PAnsiChar; +begin + sz:=PAnsiChar(CallService(MS_PROTO_GETCONTACTBASEPROTO,hContact,0)); + sz:=DBReadString(hContact,sz,'MirVer'); + if sz<>nil then + begin + result:=integer(StrPos(sz,'Miranda')); + mFreeMem(sz); + end + else + result:=-1; +end; + +function WndToContact(wnd:hwnd):integer; overload; +var + hContact:integer; + mwid:TMessageWindowInputData; + mwod:TMessageWindowOutputData; +begin + wnd:=GetParent(wnd); //!! + hContact:=PluginLink^.CallService(MS_DB_CONTACT_FINDFIRST,0,0); + with mwid do + begin + cbSize:=SizeOf(mwid); + uFlags:=MSG_WINDOW_UFLAG_MSG_BOTH; + end; + mwod.cbSize:=SizeOf(mwod); + while hContact<>0 do + begin + mwid.hContact:=hContact; + if PluginLink^.CallService(MS_MSG_GETWINDOWDATA,dword(@mwid),dword(@mwod))=0 then + begin + if {((mwod.uState and MSG_WINDOW_STATE_FOCUS)<>0) and} (mwod.hwndWindow=wnd) then + begin + result:=mwid.hContact; + exit; + end + end; + hContact:=PluginLink^.CallService(MS_DB_CONTACT_FINDNEXT,hContact,0); + end; + result:=0; +end; + +function SetCListSelContact(hContact:THANDLE):THANDLE; +var + wnd:HWND; +begin + wnd:=CallService(MS_CLUI_GETHWNDTREE,0,0); + result:=hContact; +// hContact:=SendMessage(wnd,CLM_FINDCONTACT ,hContact,0); + SendMessage(wnd,CLM_SELECTITEM ,hContact,0); +// SendMessage(wnd,CLM_ENSUREVISIBLE,hContact,0); +end; + +function GetCListSelContact:THANDLE; +begin + result:=SendMessageW(CallService(MS_CLUI_GETHWNDTREE,0,0),CLM_GETSELECTION,0,0); +end; + +function WndToContact:integer; overload; +var + wnd:HWND; +begin + wnd:=GetFocus; + if wnd=0 then + wnd:=WaitFocusedWndChild(GetForegroundWindow); + if wnd<>0 then + result:=WndToContact(wnd) + else + result:=0; + if result=0 then + result:=GetCListSelContact; +end; + +function GetContactStatus(hContact:THANDLE):integer; +var + szProto:PAnsiChar; +begin + szProto:=PAnsiChar(PluginLink^.CallService(MS_PROTO_GETCONTACTBASEPROTO,hContact,0)); + if szProto=NIL then + result:=ID_STATUS_OFFLINE + else + result:=DBReadWord(hContact,szProto,'Status',ID_STATUS_OFFLINE); +end; + +function CheckPath(filename,profilepath,path:PAnsiChar):PAnsiChar; +var + buf:array [0..511] of AnsiChar; + f:THANDLE; + p:PAnsiChar; +begin + result:=nil; + if profilepath<>nil then + StrCopy(buf,profilepath) + else + buf[0]:=#0; + StrCat(buf,filename); + f:=Reset(buf); + if dword(f)=INVALID_HANDLE_VALUE then + begin + if path<>nil then + begin + CallService(MS_UTILS_PATHTOABSOLUTE,dword(path),dword(@buf)); + p:=StrEnd(buf); + if p^<>'\' then + begin + p^:='\'; + inc(p); + p^:=#0; + end; + end + else if profilepath=nil then + exit + else + buf[0]:=#0; + StrCat(buf,filename); //path\prefix+name + f:=Reset(buf); + end; + if dword(f)<>INVALID_HANDLE_VALUE then + begin + CloseHandle(f); + StrDup(result,buf); + end; +end; + +function GetAddonFileName(prefix,altname,path:PAnsiChar;ext:PAnsiChar):PAnsiChar; +var + profilepath:array [0..511] of AnsiChar; + altfilename,filename:array [0..127] of AnsiChar; + p:PAnsiChar; +begin + CallService(MS_DB_GETPROFILEPATH,300,dword(@profilepath)); + p:=StrEnd(profilepath); + p^:='\'; inc(p); + p^:=#0; + if prefix<>nil then + begin + StrCopy(filename,prefix); + p:=StrEnd(filename); + CallService(MS_DB_GETPROFILENAME,SizeOf(filename)-integer(p-@filename),dword(p)); + ChangeExt(filename,ext); + result:=CheckPath(filename,profilepath,path); + end + else + result:=nil; + + if (result=nil) and (altname<>nil) then + begin + StrCopy(altfilename,altname); + ChangeExt(altfilename,ext); + result:=CheckPath(altfilename,profilepath,path); + end; + if result=nil then + begin + StrCat(profilepath,filename); + StrDup(result,profilepath); + end; +end; + +procedure ShowContactDialog(hContact:THANDLE;DblClk:boolean=true;anystatus:boolean=true); +var + pc:array [0..127] of AnsiChar; +begin +{ +CallService(MS_CLIST_CONTACTDOUBLECLICKED,hContact,0); +} + if (hContact<>0) and (CallService(MS_DB_CONTACT_IS,hContact,0)<>0) then + begin + StrCopy(pc,PAnsiChar(CallService(MS_PROTO_GETCONTACTBASEPROTO,hContact,0))); + if DblClk or (DBReadByte(hContact,pc,'ChatRoom',0)=1) then // chat room + begin + if not anystatus then + begin + StrCat(pc,PS_GETSTATUS); + anystatus:=(CallService(pc,0,0)<>ID_STATUS_OFFLINE); + end; + if anystatus then + begin + CallService(MS_CLIST_CONTACTDOUBLECLICKED,hContact,0); //?? + // if chat exist, open chat + // else create new session + end; + end + else + begin + if PluginLink^.ServiceExists(MS_MSG_CONVERS)<>0 then // Convers compat. + CallService(MS_MSG_CONVERS,hContact,0) + else + CallService(MS_MSG_SENDMESSAGE,hContact,0) + end; + end; +end; + +procedure SendChatText(pszID:pointer;pszModule:PAnsiChar;pszText:pointer); +var + gcd:TGCDEST; + gce:TGCEVENT; +begin + gcd.pszModule:=pszModule; + gcd.iType :=GC_EVENT_SENDMESSAGE; + gcd.szID.w :=pszID; + + FillChar(gce,SizeOf(TGCEVENT),0); + gce.cbSize :=SizeOf(TGCEVENT); + gce.pDest :=@gcd; + gce.bIsMe :=true; + gce.szText.w:=pszText; + gce.dwFlags :=GCEF_ADDTOLOG+GC_UNICODE; + gce.time :=GetCurrentTime; + + PluginLink^.CallServiceSync(MS_GC_EVENT,0,dword(@gce)); +end; + +procedure SendToChat(hContact:THANDLE;pszText:PWideChar); +var + gci:TGC_INFO; + pszModule:PAnsiChar; + i,cnt:integer; +begin + pszModule:=PAnsiChar(CallService(MS_PROTO_GETCONTACTBASEPROTO,hContact,0)); + cnt:=CallService(MS_GC_GETSESSIONCOUNT,0,dword(pszModule)); + i:=0; + gci.pszModule:=pszModule; + while i0 do + begin + if is_chat then + begin + if IsChat(hContact) then + begin + pw:=DBReadUnicode(hContact,proto,'ChatRoomID'); + if StrCmpW(pw,dbv.szVal.W)=0 then result:=hContact; + mFreeMem(pw); + end + end + else + begin + if DBReadSetting(hContact,proto,uid,@ldbv)=0 then + begin + if dbv._type=ldbv._type then + begin + case dbv._type of + DBVT_DELETED: ; + DBVT_BYTE : if dbv.bVal=ldbv.bVal then result:=hContact; + DBVT_WORD : if dbv.wVal=ldbv.wVal then result:=hContact; + DBVT_DWORD : if dbv.dVal=ldbv.dVal then result:=hContact; + DBVT_UTF8, + DBVT_ASCIIZ : if StrCmp (dbv.szVal.A,ldbv.szVal.A)=0 then result:=hContact; + DBVT_WCHAR : if StrCmpW(dbv.szVal.W,ldbv.szVal.W)=0 then result:=hContact; + DBVT_BLOB : begin + if dbv.cpbVal = ldbv.cpbVal then + begin + if CompareMem(dbv.pbVal,ldbv.pbVal,dbv.cpbVal) then + result:=hContact; + end; + end; + end; + if result<>0 then break; + end; + DBFreeVariant(@ldbv); + end; + end; + hContact:=CallService(MS_DB_CONTACT_FINDNEXT,hContact,0); + end; +end; + +function IsContactActive(hContact:THANDLE;var proto:pAnsiChar):integer; overload; +var + p:PPROTOACCOUNT; + dbv :TDBVARIANT; + dbcgs:TDBCONTACTGETSETTING; + name: array [0..31] of AnsiChar; +begin + + dbv._type :=DBVT_ASCIIZ; + dbv.szVal.a:=@name; + dbv.cchVal :=SizeOf(name); + dbcgs.pValue :=@dbv; + dbcgs.szModule :='Protocol'; + dbcgs.szSetting:='p'; + + if PluginLink^.CallService(MS_DB_CONTACT_GETSETTINGSTATIC,hContact,dword(@dbcgs))=0 then + begin + result:=0; + + if PluginLink^.ServiceExists(MS_PROTO_GETACCOUNT)<>0 then + begin + p:=PPROTOACCOUNT(CallService(MS_PROTO_GETACCOUNT,0,dword(dbv.szVal.a))); + if p=nil then + result:=-2 // deleted + else if (p^.bIsEnabled=0) or p^.bDynDisabled then + result:=-1; // disabled + end + else + begin + if CallService(MS_PROTO_ISPROTOCOLLOADED,0,dword(dbv.szVal.a))=0 then + result:=-1; + end; + + if (result=0) and (DBReadByte(hContact,strCList,'Hidden',0)=0) then + begin + result:=255; + if PluginLink^.ServiceExists(MS_MC_GETMETACONTACT)<>0 then + begin + if CallService(MS_MC_GETMETACONTACT,hContact,0)<>0 then + result:=2; + if StrCmp( + PAnsiChar(CallService(MS_PROTO_GETCONTACTBASEPROTO,hContact,0)), + PAnsiChar(CallService(MS_MC_GETPROTOCOLNAME,0,0)))=0 then + result:=1; + end; + end; + if @proto<>nil then + StrDup(proto,dbv.szVal.a); + end + else + begin + result:=-2; + if @proto<>nil then + proto:=nil; + end; + +end; + +function IsContactActive(hContact:THANDLE):integer; overload; +type + ppAnsiChar = ^pAnsiChar; +begin + result:=IsContactActive(hContact,ppAnsiChar(nil)^); +end; + +// Import plugin function adaptation +function CreateGroupW(name:pWideChar;hContact:THANDLE):integer; +var + groupId:integer; + groupIdStr:array [0..10] of AnsiChar; + dbv:TDBVARIANT; + cgs:TDBCONTACTGETSETTING; + grbuf:array [0..127] of WideChar; + p:pWideChar; +begin + if (name=nil) or (name^=#0) then + begin + result:=0; + exit; + end; + + StrCopyW(@grbuf[1],name); + grbuf[0]:=WideChar(1 or GROUPF_EXPANDED); + + // Check for duplicate & find unused id + groupId:=0; + cgs.szModule:='CListGroups'; + cgs.pValue :=@dbv; + repeat + dbv._type:=DBVT_WCHAR; + cgs.szSetting:=IntToStr(groupIdStr,groupId); + if PluginLink^.CallService(MS_DB_CONTACT_GETSETTING_STR,0,lParam(@cgs))<>0 then + break; + + if StrCmpW(dbv.szVal.w+1,@grbuf[1])=0 then + begin + if hContact<>0 then + DBWriteUnicode(hContact,strCList,'Group',@grbuf[1]); + + DBFreeVariant(@dbv); + result:=0; + exit; + end; + + DBFreeVariant(@dbv); + inc(groupid); + until false; + + DBWriteUnicode(0,'CListGroups',groupIdStr,grbuf); + + if hContact<>0 then + DBWriteUnicode(hContact,strCList,'Group',@grbuf[1]); + + p:=StrRScanW(grbuf,'\'); + if p<>nil then + begin + p^:=#0; + CreateGroupW(grbuf+1,0); + end; + + result:=1; +end; + +function CreateGroup(name:pAnsiChar;hContact:THANDLE):integer; +var + groupId:integer; + groupIdStr:array [0..10] of AnsiChar; + dbv:TDBVARIANT; + cgs:TDBCONTACTGETSETTING; + grbuf:array [0..127] of AnsiChar; + p:pAnsiChar; +begin + if (name=nil) or (name^=#0) then + begin + result:=0; + exit; + end; + + StrCopy(@grbuf[1],name); + grbuf[0]:=CHAR(1 or GROUPF_EXPANDED); + + // Check for duplicate & find unused id + groupId:=0; + cgs.szModule:='CListGroups'; + cgs.pValue :=@dbv; + repeat + dbv._type:=DBVT_ASCIIZ; + cgs.szSetting:=IntToStr(groupIdStr,groupId); + if PluginLink^.CallService(MS_DB_CONTACT_GETSETTING_STR,0,lParam(@cgs))<>0 then + break; + + if StrCmp(dbv.szVal.a+1,@grbuf[1])=0 then + begin + if hContact<>0 then + DBWriteString(hContact,strCList,'Group',@grbuf[1]); + + DBFreeVariant(@dbv); + result:=0; + exit; + end; + + DBFreeVariant(@dbv); + inc(groupid); + until false; + + DBWriteString(0,'CListGroups',groupIdStr,grbuf); + + if hContact<>0 then + DBWriteString(hContact,strCList,'Group',@grbuf[1]); + + p:=StrRScan(grbuf,'\'); + if p<>nil then + begin + p^:=#0; + CreateGroup(grbuf+1,0); + end; + + result:=1; +end; + +function MakeGroupMenu(idxfrom:integer=100):HMENU; +var + sl:PWStrList; + i:integer; + b:array [0..15] of AnsiChar; + p:pWideChar; +begin + result:=CreatePopupMenu; + i:=0; + AppendMenuW(result,MF_STRING,idxfrom,TranslateW('')); + AppendMenuW(result,MF_SEPARATOR,0,nil); + sl:=NewWStrList; + repeat + p:=DBReadUnicode(0,'CListGroups',IntToStr(b,i),nil); + if p=nil then break; + sl.Add(p+1); + mFreeMem(p); + inc(i); + until false; + sl.Sort(false); + for i:=0 to sl.Count-1 do + begin + AppendMenuW(result,MF_STRING,idxfrom+1,pWideChar(sl.Items[i])); + end; + sl.Clear; + sl.Free; +end; + +function GetNewGroupName(parent:HWND):pWideChar; +var + mmenu:HMENU; + i:integer; + buf:array [0..63] of WideChar; + pt:TPoint; +begin + mmenu:=MakeGroupMenu; + GetCursorPos(pt); + i:=integer(TrackPopupMenu(mmenu,TPM_RETURNCMD+TPM_NONOTIFY,pt.x,pt.y,0,parent,nil)); + if i>0 then + begin + GetMenuStringW(mmenu,i,buf,HIGH(buf)+1,MF_BYCOMMAND); + StrDupW(result,buf); + end; + DestroyMenu(mmenu); +end; + +(* +static int __inline NLog(AnsiChar *msg) { + return CallService(MS_NETLIB_LOG, (WPARAM)hNetlibUser, (LPARAM)msg); +} +*) +function GetFile(url:PAnsiChar;save_file:PAnsiChar; + hNetLib:THANDLE=0;recurse_count:integer=0):bool; +var + nlu:TNETLIBUSER; + req :TNETLIBHTTPREQUEST; + resp:PNETLIBHTTPREQUEST; + hSaveFile:THANDLE; + i:integer; +begin + result:=false; + if recurse_count>MAX_REDIRECT_RECURSE then + exit; + if (url=nil) or (url^=#0) or (save_file=nil) or (save_file^=#0) then + exit; + + FillChar(req,SizeOf(req),0); + req.cbSize :=SizeOf(req); + req.requestType:=REQUEST_GET; + req.szUrl :=url; + req.flags :=NLHRF_NODUMP; + + + FillChar(nlu,SizeOf(nlu),0); + if hNetLib=0 then + begin + nlu.cbSize :=SizeOf(nlu); + nlu.flags :=NUF_HTTPCONNS or NUF_NOHTTPSOPTION or NUF_OUTGOING or NUF_NOOPTIONS; + nlu.szSettingsModule:='dummy'; + hNetlib:=CallService(MS_NETLIB_REGISTERUSER,0,dword(@nlu)); + end; + + resp:=pointer(CallService(MS_NETLIB_HTTPTRANSACTION,hNetlib,dword(@req))); + + if resp<>nil then + begin + if resp^.resultCode=200 then + begin + hSaveFile:=Rewrite(save_file); + if dword(hSaveFile)<>INVALID_HANDLE_VALUE then + begin + BlockWrite(hSaveFile,resp^.pData^,resp^.dataLength); + CloseHandle(hSaveFile); + result:=true; + end + end + else if (resp.resultCode>=300) and (resp.resultCode<400) then + begin + // get new location + for i:=0 to resp^.headersCount-1 do + begin + //MessageBox(0,resp^.headers[i].szValue, resp^.headers[i].szName,MB_OK); + if StrCmp(resp^.headers^[i].szName,'Location')=0 then + begin + result:=GetFile(resp^.headers^[i].szValue,save_file,hNetLib,recurse_count+1); + break; + end + end; + end + else + begin +{ + _stprintf(buff, TranslateT("Failed to download \"%s\" - Invalid response, code %d"), plugin_name, resp->resultCode); + + ShowError(buff); + AnsiChar *ts = GetAString(buff); + NLog(ts); +} + end; + CallService(MS_NETLIB_FREEHTTPREQUESTSTRUCT,0,dword(resp)); + + if nlu.cbSize<>0 then + CallService(MS_NETLIB_CLOSEHANDLE,hNetLib,0); + end; +end; + +function GetFile(url:PWideChar;save_file:PWideChar; + hNetLib:THANDLE=0;recurse_count:integer=0):bool; +var + aurl,asave:array [0..MAX_PATH-1] of AnsiChar; +begin + FastWideToAnsiBuf(url,aurl); + FastWideToAnsiBuf(save_file,asave); + result:=GetFile(aurl,asave,hNetLib,0); +end; + +function GetProxy(hNetLib:THANDLE):PAnsiChar; +var + nlus:TNETLIBUSERSETTINGS; + pc:PAnsiChar; + proxy:array [0..127] of AnsiChar; +begin + result:=nil; + nlus.cbSize:=SizeOf(nlus); + if CallService(MS_NETLIB_GETUSERSETTINGS,hNetLib,dword(@nlus))<>0 then + begin + if nlus.useProxy<>0 then + begin + if nlus.proxyType<>PROXYTYPE_IE then + begin + pc:=@proxy; + if nlus.szProxyServer<>nil then + begin + if nlus.useProxyAuth<>0 then + begin + if nlus.szProxyAuthUser<>nil then + begin + pc:=StrCopyE(proxy,nlus.szProxyAuthUser); + if nlus.szProxyAuthPassword<>nil then + begin + pc^:=':'; inc(pc); + pc:=StrCopyE(pc,nlus.szProxyAuthPassword); + end; + pc^:='@'; + inc(pc); + end; + end; + pc:=StrCopyE(pc,nlus.szProxyServer); + if nlus.wProxyPort<>0 then + begin + pc^:=':'; inc(pc); + IntToStr(pc,nlus.wProxyPort); + end; + end; + StrDup(result,proxy); + end + else // use IE proxy + begin + mGetMem(result,1); + result^:=#0; + end; + end; + end; +end; + +function LoadImageURL(url:pAnsiChar;size:integer=0):HBITMAP; +var + nlu:TNETLIBUSER; + req :TNETLIBHTTPREQUEST; + resp:PNETLIBHTTPREQUEST; + hNetLib:THANDLE; + im:TIMGSRVC_MEMIO; +begin + result:=0; + if (url=nil) or (url^=#0) then + exit; + + FillChar(req,SizeOf(req),0); + req.cbSize :=SizeOf(req); + req.requestType:=REQUEST_GET; + req.szUrl :=url; + req.flags :=NLHRF_NODUMP; + + FillChar(nlu,SizeOf(nlu),0); + nlu.cbSize :=SizeOf(nlu); + nlu.flags :=NUF_HTTPCONNS or NUF_NOHTTPSOPTION or NUF_OUTGOING or NUF_NOOPTIONS; + nlu.szSettingsModule:='dummy'; + hNetlib:=CallService(MS_NETLIB_REGISTERUSER,0,dword(@nlu)); + + resp:=pointer(CallService(MS_NETLIB_HTTPTRANSACTION,hNetlib,dword(@req))); + + if resp<>nil then + begin + if resp^.resultCode=200 then + begin + im.iLen :=resp.dataLength; + im.pBuf :=resp.pData; + im.flags:=size shl 16; + im.fif :=FIF_JPEG; + result :=CallService(MS_IMG_LOADFROMMEM,dword(@im),0); +// if result<>0 then +// DeleteObject(SendMessage(wnd,STM_SETIMAGE,IMAGE_BITMAP,result)); //!! + end; + CallService(MS_NETLIB_FREEHTTPREQUESTSTRUCT,0,dword(resp)); + end; + CallService(MS_NETLIB_CLOSEHANDLE,hNetLib,0); +end; + +function RegisterSingleIcon(resname,ilname,descr,group:PAnsiChar):int; +var + sid:TSKINICONDESC; +begin + FillChar(sid,SizeOf(TSKINICONDESC),0); + sid.cbSize :=SizeOf(TSKINICONDESC); + sid.cx :=16; + sid.cy :=16; + sid.flags :=0; + sid.szSection.a:=group; + + sid.hDefaultIcon :=LoadImage(hInstance,resname,IMAGE_ICON,16,16,0); + sid.pszName :=ilname; + sid.szDescription.a:=descr; + result:=PluginLink^.CallService(MS_SKIN2_ADDICON,0,dword(@sid)); + DestroyIcon(sid.hDefaultIcon); +end; + +end. diff --git a/delphi/Awkward/utils/playlist.pas b/delphi/Awkward/utils/playlist.pas new file mode 100644 index 0000000..d1fb552 --- /dev/null +++ b/delphi/Awkward/utils/playlist.pas @@ -0,0 +1,431 @@ +{Playlist process} +unit playlist; + +interface + +type + tPlaylist = class + private + fShuffle :boolean; + PlSize :cardinal; // playlist entries + PlCapacity:cardinal; + base :pWideChar; + name :pWideChar; + descr :pWideChar; + PlStrings :array of PWideChar; + CurElement:cardinal; + PlOrder :array of cardinal; + CurOrder :cardinal; + + procedure SetShuffle(value:boolean); + function GetShuffle:boolean; + procedure DoShuffle; + + function GetTrackNumber:integer; + procedure SetTrackNumber(value:integer); + + procedure AddLine(name,descr:pWideChar;new:boolean=true); + function ProcessElement(num:integer=-1):PWideChar; //virtual; + + public + constructor Create(fName:pWideChar); + destructor Free; + + procedure SetBasePath(path:pWideChar); + + function GetSong(number:integer=-1):pWideChar; + function GetCount:integer; + + function Next :pWideChar; + function Previous:pWideChar; + + property Track :integer read GetTrackNumber write SetTrackNumber; + property Shuffle:boolean read GetShuffle write SetShuffle; + end; + +function isPlaylist(fname:pWideChar):integer; +function CreatePlaylist(fname:pWideChar):tPlaylist; + +implementation + +uses windows, common, io;//, m_api, mirutils; + +const + plSizeStart = 2048; + plSizeStep = 256; +const + pltM3OLD = $100; + pltM3UTF = $200; + +type + tM3UPlaylist = class(tPlayList) + private + public + constructor Create(fName:pWideChar); + end; + + tPLSPlaylist = class(tPlayList) + private + public + constructor Create(fName:pWideChar); + end; + +function isPlaylist(fname:pWideChar):integer; +var + ext:array [0..7] of WideChar; +begin + GetExt(fname,ext,7); + if StrCmpW(ext,'M3U',3)=0 then result:=1 + else if StrCmpW(ext,'PLS' )=0 then result:=2 + else result:=0; +end; + +function CreatePlaylist(fname:pWideChar):tPlaylist; +begin + case isPlaylist(fname) of + 1: result:=tM3UPlaylist.Create(fName); + 2: result:=tPLSPlaylist.Create(fName); + else result:=nil; + end; +end; + +//----- ----- + +function SkipLine(var p:PWideChar):bool; +begin + while p^>=' ' do inc(p); + while p^<=' ' do // Skip spaces too + begin + if p^=#0 then + begin + result:=false; + exit; + end; + p^:=#0; + inc(p); + end; + result:=true; +end; + +constructor tM3UPlaylist.Create(fName:pWideChar); +var + f:THANDLE; + i:integer; + p:PAnsiChar; + pp,pd:pWideChar; + plBuf:pAnsiChar; + plBufW:pWideChar; + pltNew:boolean; + lname,ldescr:pWideChar; + finish:boolean; +begin + inherited; + + // Load into mem + f:=Reset(fName); + if dword(f)<>INVALID_HANDLE_VALUE then + begin + i:=integer(FileSize(f)); + if i=-1 then + i:=integer(GetFSize(fName)); + if i<>-1 then + begin + mGetMem(PlBuf,i+1); + BlockRead(f,PlBuf^,i); + CloseHandle(f); + PlBuf[i]:=#0; + + p:=PlBuf; + if (pdword(p)^ and $00FFFFFF)=$00BFBBEF then + begin + inc(p,3); + UTF8ToWide(p,plBufW) + end + else + AnsiToWide(p,plBufW); + + mFreeMem(plBuf); + + pp:=plBufW; + pltNew:=StrCmpW(pp,'#EXTM3U',7)=0; + if pltNew then SkipLine(pp); + + repeat + if pltNew then + begin + pd:=StrScanW(pp,','); + if pd<>nil then + begin + ldescr:=pd+1; + if not SkipLine(pp) then break; + end; + end; + lname:=pp; + finish:=SkipLine(pp); + AddLine(lname,ldescr); + until not finish; + + mFreeMem(plBufW); + end; + end; + +end; + +//----- ----- + +constructor tPLSPlaylist.Create(fName:pWideChar); +var + buf:array [0..MAX_PATH-1] of AnsiChar; + lname,ldescr:pWideChar; + ffile,ftitle:array [0..31] of AnsiChar; + plName:array [0..127] of AnsiChar; + f,t:pAnsiChar; + i,size:integer; + plFile:pAnsiChar; +begin + inherited; + + WideToAnsi(fName,PlFile); + GetPrivateProfileSectionNamesA(buf,127,PlFile); + StrCopy(plName,buf); + size:=GetPrivateProfileIntA(PlName,'NumberOfEntries',0,PlFile); + f:=StrCopyE(ffile ,'File'); + t:=StrCopyE(ftitle,'Title'); + for i:=1 to size do + begin + IntToStr(f,i); + GetPrivateProfileStringA(PlName,ffile,'',buf,SizeOf(buf),PlFile); + AnsiToWide(buf,lname); + + IntToStr(t,i); + GetPrivateProfileStringA(PlName,ftitle,'',buf,SizeOf(buf),PlFile); + AnsiToWide(buf,ldescr); + + AddLine(lname,ldescr,false); + end; + mFreeMem(plFile); +end; + +//----- ----- + +constructor tPlaylist.Create(fName:pWideChar); +begin + CurElement:=0; + base:=nil; + name:=nil; + descr:=nil; + Shuffle:=false; + plSize:=0; + + SetBasePath(fname); +end; + +destructor tPlaylist.Free; +var + i:integer; +begin + PlOrder:=nil; + + mFreeMem(base); + mFreeMem(name); + mFreeMem(descr); + + for i:=0 to PlSize-1 do + begin + mFreeMem(plStrings[i*2]); + mFreeMem(plStrings[i*2+1]); + end; + PlStrings:=nil; +end; + +procedure tPlaylist.AddLine(name,descr:pWideChar;new:boolean=true); +begin + if PlCapacity=0 then + begin + PlCapacity:=plSizeStart; + SetLength(PlStrings,plSizeStart*2); + fillChar(plStrings[0],plSizeStart*2*SizeOf(pWideChar),0); + end + else if plSize=PlCapacity then + begin + inc(plCapacity,plSizeStep); + SetLength(PlStrings,plCapacity*2); + fillChar(plStrings[plSize],plSizeStep*2*SizeOf(pWideChar),0); + end; + if new then + begin + StrDupW(plStrings[plSize*2 ],name); + StrDupW(plStrings[plSize*2+1],descr); + end + else + begin + plStrings[plSize*2 ]:=name; + plStrings[plSize*2+1]:=descr; + end; + inc(plSize); +end; + +procedure tPlaylist.SetBasePath(path:pWideChar); +var + buf:array [0..MAX_PATH-1] of WideChar; + p,pp:pWideChar; +begin + mFreeMem(base); + + pp:=ExtractW(path,false); + p:=StrCopyEW(buf,pp); + mFreeMem(pp); + + if ((p-1)^<>'\') and ((p-1)^<>'/') then + begin + if StrScanW(buf,'/')<>nil then + p^:='/' + else + p^:='\'; + inc(p); + end; + p^:=#0; + StrDupW(base,buf); +end; + +function tPlaylist.GetCount:integer; +begin + result:=PlSize; +end; + +function tPlaylist.GetTrackNumber:integer; +begin + if fShuffle then + result:=CurOrder + else + result:=CurElement; +end; + +procedure tPlaylist.SetTrackNumber(value:integer); +begin + if value<0 then + value:=0 + else if value>=Integer(PlSize) then + value:=PlSize-1; + + if fShuffle then + CurOrder:=value + else + CurElement:=value; +end; + +function tPlaylist.ProcessElement(num:integer=-1):pWideChar; +begin + if num<0 then + num:=Track + else if num>=integer(PlSize) then + num:=PlSize-1; + + result:=plStrings[num*2]; +end; + +function tPlaylist.GetSong(number:integer=-1):PWideChar; +var + buf:array [0..MAX_PATH-1] of WideChar; +begin + result:=ProcessElement(number); + + if (result<>nil) and not isPathAbsolute(result) and (base<>nil) then + begin + StrCopyW(StrCopyEW(buf,base),result); + mFreeMem(result); + StrDupW(result,buf); + end; +end; + +procedure tPlaylist.SetShuffle(value:boolean); +begin + if value then + begin +// if not fShuffle then // need to set Shuffle + DoShuffle; + end; + + fShuffle:=value; +end; + +function tPlaylist.GetShuffle:boolean; +begin + result:=fShuffle; +end; + +procedure tPlaylist.DoShuffle; +var + i,RandInx: cardinal; + SwapItem: cardinal; +begin + SetLength(PlOrder,PlSize); + Randomize; + for i:=0 to PlSize-1 do + PlOrder[i]:=i; + if PlSize>1 then + begin + for i:=0 to PlSize-2 do + begin + RandInx:=cardinal(Random(PlSize-i)); + SwapItem:=PlOrder[i]; + PlOrder[i ]:=PlOrder[RandInx]; + PlOrder[RandInx]:=SwapItem; + end; + end; + CurOrder:=0; +end; + +function tPlaylist.Next:PWideChar; +begin + if PlSize<>0 then + begin + if not Shuffle then + begin + inc(CurElement); + if CurElement=PlSize then + CurElement:=0; + end + else // if mode=plShuffle then + begin + inc(CurOrder); + if CurOrder=PlSize then + begin + DoShuffle; + CurOrder:=0; + end; + CurElement:=PlOrder[CurOrder]; + end; + result:=GetSong; + end + else + result:=nil; +end; + +function tPlaylist.Previous:PWideChar; +begin + if PlSize<>0 then + begin + if not Shuffle then + begin + if CurElement=0 then + CurElement:=PlSize; + Dec(CurElement); + end + else // if mode=plShuffle then + begin + if CurOrder=0 then + begin + DoShuffle; + CurOrder:=PlSize; + end; + dec(CurOrder); + CurElement:=PlOrder[CurOrder]; + end; + result:=GetSong; + end + else + result:=nil; +end; + +end. diff --git a/delphi/Awkward/utils/protocols.pas b/delphi/Awkward/utils/protocols.pas new file mode 100644 index 0000000..ba14288 --- /dev/null +++ b/delphi/Awkward/utils/protocols.pas @@ -0,0 +1,573 @@ +unit protocols; + +interface + +uses windows,m_api; + +function FindProto(proto:PAnsiChar):integer; + +function GetStatusNum(status:integer):integer; +function GetNumProto:cardinal; + +function GetProtoSetting(ProtoNum:cardinal;param:boolean=false):dword; +procedure SetProtoSetting(ProtoNum:cardinal;mask:dword;param:boolean=false); + +function IsTunesSupported (ProtoNum:cardinal):bool; +function IsXStatusSupported(ProtoNum:cardinal):bool; +function IsChatSupported (ProtoNum:cardinal):bool; + +function GetProtoStatus (ProtoNum:cardinal):integer; +function GetProtoStatusNum(ProtoNum:cardinal):integer; +function GetProtoName (ProtoNum:cardinal):PAnsiChar; + +procedure FillProtoList (list:hwnd;withIcons:bool=false); +procedure CheckProtoList (list:hwnd); +procedure FillStatusList (proto:cardinal;list:hwnd;withIcons:bool=false); +procedure CheckStatusList(list:hwnd;ProtoNum:cardinal); + +function CreateProtoList:integer; +procedure FreeProtoList; + +function SetStatus(proto:PAnsiChar;status:integer;txt:PAnsiChar=pointer(-1)):integer; +function SetXStatus(proto:PAnsiChar;newstatus:integer; + txt:pWideChar=nil;title:pWideChar=nil):integer; +function GetXStatus(proto:PAnsiChar;txt:pointer=nil;title:pointer=nil):integer; + +const + psf_online = $0001; + psf_invisible = $0002; + psf_shortaway = $0004; + psf_longaway = $0008; + psf_lightdnd = $0010; + psf_heavydnd = $0020; + psf_freechat = $0040; + psf_outtolunch = $0080; + psf_onthephone = $0100; + psf_enabled = $0800; + psf_all = $08FF; + psf_chat = $1000; + psf_icq = $2000; + psf_tunes = $4000; + +implementation + +uses commctrl,common,dbsettings; + +{$include m_newawaysys.inc} + +const + defproto = '- default -'; + +const + NumStatus = 10; + StatCodes:array [0..NumStatus-1] of integer=( + ID_STATUS_OFFLINE, + ID_STATUS_ONLINE, + ID_STATUS_INVISIBLE, + ID_STATUS_AWAY, + ID_STATUS_NA, + ID_STATUS_OCCUPIED, + ID_STATUS_DND, + ID_STATUS_FREECHAT, + ID_STATUS_OUTTOLUNCH, + ID_STATUS_ONTHEPHONE); +const + StatNames:array [0..NumStatus-1] of PWideChar=( + 'Default'{'Offline'},'Online','Invisible','Away','N/A','Occupied','DND', + 'Free for chat','Out to lunch','On the Phone'); + +type + pMyProto = ^tMyProto; + tMyProto = record + name :PAnsiChar; +// xstat :integer; // old ICQ XStatus + enabled :integer; + status :integer; // mask + param :dword; + end; + pMyProtos = ^tMyProtos; + tMyProtos = array [0..100] of tMyProto; + +var + protos:pMyProtos; + NumProto:cardinal; + NASPresents:bool; + +function FindProto(proto:PAnsiChar):integer; +var + i:integer; +begin + for i:=1 to NumProto do + begin + if StrCmp(proto,protos^[i].name)=0 then + begin + result:=i; + exit; + end; + end; + result:=0; +end; + +function IsTunesSupported(ProtoNum:cardinal):bool; +begin + if ProtoNum>100 then + ProtoNum:=FindProto(PAnsiChar(ProtoNum)); + if (ProtoNum<=NumProto) and ((protos^[ProtoNum].status and psf_tunes)<>0) then + result:=true + else + result:=false; +end; + +function IsXStatusSupported(ProtoNum:cardinal):bool; +begin + if ProtoNum>100 then + ProtoNum:=FindProto(PAnsiChar(ProtoNum)); + if (ProtoNum<=NumProto) and ((protos^[ProtoNum].status and psf_icq)<>0) then + result:=true + else + result:=false; +end; + +function IsChatSupported(ProtoNum:cardinal):bool; +begin + if ProtoNum>100 then + ProtoNum:=FindProto(PAnsiChar(ProtoNum)); + if (ProtoNum<=NumProto) and ((protos^[ProtoNum].status and psf_chat)<>0) then + result:=true + else + result:=false; +end; + +function GetProtoSetting(ProtoNum:cardinal;param:boolean=false):dword; +begin + if ProtoNum>100 then + ProtoNum:=FindProto(PAnsiChar(ProtoNum)); + if ProtoNum<=NumProto then + begin + if param then + result:=protos^[ProtoNum].param + else + result:=protos^[ProtoNum].enabled + end + else + result:=0; +end; + +procedure SetProtoSetting(ProtoNum:cardinal;mask:dword;param:boolean=false); +begin + if ProtoNum>100 then + ProtoNum:=FindProto(PAnsiChar(ProtoNum)); + if ProtoNum<=NumProto then + begin + if param then + protos^[ProtoNum].param:=mask + else + protos^[ProtoNum].enabled:=mask; + end; +end; + +function GetStatusNum(status:integer):integer; +var + i:integer; +begin + for i:=0 to NumStatus-1 do + if StatCodes[i]=status then + begin + result:=i; + exit; + end; + result:=0; //-1 +end; + +function GetProtoStatus(ProtoNum:cardinal):integer; +begin + if ProtoNum>100 then + ProtoNum:=FindProto(PAnsiChar(ProtoNum)); + result:=CallProtoService(protos^[ProtoNum].name,PS_GETSTATUS,0,0); +end; + +function GetProtoStatusNum(ProtoNum:cardinal):integer; +begin + if ProtoNum>100 then + ProtoNum:=FindProto(PAnsiChar(ProtoNum)); + result:=GetStatusNum(GetProtoStatus(ProtoNum)); +end; + +function GetNumProto:cardinal; +begin + result:=NumProto; +end; + +function GetProtoName(ProtoNum:cardinal):PAnsiChar; +begin + if ProtoNum<=NumProto then + result:=protos^[ProtoNum].name + else + result:=nil; +end; + +procedure FillProtoList(list:hwnd;withIcons:bool=false); +var + item:TLVITEMA; + lvc:TLVCOLUMN; + i,NewItem:integer; + cli:PCLIST_INTERFACE; +begin + FillChar(lvc,SizeOf(lvc),0); + ListView_SetExtendedListViewStyle(list, LVS_EX_CHECKBOXES); + if withIcons then + begin + dword(cli):=CallService(MS_CLIST_RETRIEVE_INTERFACE,0,0); + SetWindowLongW(list,GWL_STYLE, + GetWindowLongW(list,GWL_STYLE) or LVS_SHAREIMAGELISTS); + ListView_SetImageList(list, + CallService(MS_CLIST_GETICONSIMAGELIST,0,0),LVSIL_SMALL); + lvc.mask:=LVCF_FMT+LVCF_IMAGE + end + else + begin + cli:=nil; + lvc.mask:=LVCF_FMT; + end; + + lvc.fmt :={LVCFMT_IMAGE or} LVCFMT_LEFT; + ListView_InsertColumn(list,0,lvc); + + FillChar(item,SizeOf(item),0); + if withIcons then + item.mask:=LVIF_TEXT+LVIF_IMAGE + else + item.mask:=LVIF_TEXT; + for i:=0 to NumProto do + begin + item.iItem:=i; + item.pszText:=protos^[i].name; + if withIcons and (i>0) then + item.iImage:=cli^.pfnIconFromStatusMode(item.pszText,ID_STATUS_ONLINE,0); + newItem:=ListView_InsertItemA(list,item); + if newItem>=0 then + ListView_SetCheckState(list,newItem,(protos^[i].enabled and psf_enabled)<>0) + end; + ListView_SetItemState (list,0,LVIS_FOCUSED or LVIS_SELECTED,LVIS_FOCUSED or LVIS_SELECTED); + + ListView_SetColumnWidth(list,0,LVSCW_AUTOSIZE); +end; + +procedure CheckProtoList(list:hwnd); +var + i:integer; +begin + for i:=1 to ListView_GetItemCount(list) do + begin + with protos^[i] do + if ListView_GetCheckState(list,i)=BST_CHECKED then + enabled:=enabled or psf_enabled + else + enabled:=enabled and not psf_enabled; + end; +end; + +procedure FillStatusList(proto:cardinal;list:hwnd;withIcons:bool=false); + + procedure AddString(num:integer;enabled:boolean;cli:PCLIST_INTERFACE); + var + item:LV_ITEMW; + NewItem:integer; + begin + FillChar(item,SizeOf(item),0); + item.iItem :=num; + item.lParam :=StatCodes[num]; + if cli<>nil then + begin + item.mask :=LVIF_TEXT+LVIF_PARAM+LVIF_IMAGE; + item.iImage:=cli^.pfnIconFromStatusMode(protos^[proto].name,item.lParam,0); + end + else + item.mask :=LVIF_TEXT+LVIF_PARAM; + item.pszText:=TranslateW(StatNames[num]); + newItem:=SendMessageW(list,LVM_INSERTITEMW,0,dword(@item)); + if newItem>=0 then + ListView_SetCheckState(list,newItem,enabled); + end; + +var + lvc:TLVCOLUMN; + cli:PCLIST_INTERFACE; +begin + if proto=0 then + withIcons:=false; + ListView_DeleteAllItems(list); + ListView_DeleteColumn(list,0); + FillChar(lvc,SizeOf(lvc),0); + ListView_SetExtendedListViewStyle(list, LVS_EX_CHECKBOXES); + if withIcons then + begin + dword(cli):=CallService(MS_CLIST_RETRIEVE_INTERFACE,0,0); + SetWindowLongW(list,GWL_STYLE, + GetWindowLongW(list,GWL_STYLE) or LVS_SHAREIMAGELISTS); + ListView_SetImageList(list, + CallService(MS_CLIST_GETICONSIMAGELIST,0,0),LVSIL_SMALL); + lvc.mask:=LVCF_FMT+LVCF_IMAGE + end + else + begin + cli:=nil; + SetWindowLongW(list,GWL_STYLE, + GetWindowLongW(list,GWL_STYLE) and not LVS_SHAREIMAGELISTS); +// ListView_SetImageList(list,0,LVSIL_SMALL); + lvc.mask:=LVCF_FMT; + end; + lvc.fmt:={LVCFMT_IMAGE or} LVCFMT_LEFT; + ListView_InsertColumn(list,0,lvc); + + AddString(0,true,nil); + ListView_SetItemState (list,0,LVIS_FOCUSED or LVIS_SELECTED,$000F); + with protos^[proto] do + begin + if (status and psf_online )<>0 then AddString(1,(enabled and psf_online )<>0,cli); + if (status and psf_invisible )<>0 then AddString(2,(enabled and psf_invisible )<>0,cli); + if (status and psf_shortaway )<>0 then AddString(3,(enabled and psf_shortaway )<>0,cli); + if (status and psf_longaway )<>0 then AddString(4,(enabled and psf_longaway )<>0,cli); + if (status and psf_lightdnd )<>0 then AddString(5,(enabled and psf_lightdnd )<>0,cli); + if (status and psf_heavydnd )<>0 then AddString(6,(enabled and psf_heavydnd )<>0,cli); + if (status and psf_freechat )<>0 then AddString(7,(enabled and psf_freechat )<>0,cli); + if (status and psf_outtolunch)<>0 then AddString(8,(enabled and psf_outtolunch)<>0,cli); + if (status and psf_onthephone)<>0 then AddString(9,(enabled and psf_onthephone)<>0,cli); + end; + ListView_SetColumnWidth(list,0,LVSCW_AUTOSIZE); +end; + +procedure CheckStatusList(list:hwnd;ProtoNum:cardinal); + + procedure SetStatusMask(stat:integer;state:bool); + var + i:integer; + begin + case stat of + ID_STATUS_ONLINE: i:=psf_online; + ID_STATUS_INVISIBLE: i:=psf_invisible; + ID_STATUS_AWAY: i:=psf_shortaway; + ID_STATUS_NA: i:=psf_longaway; + ID_STATUS_OCCUPIED: i:=psf_lightdnd; + ID_STATUS_DND: i:=psf_heavydnd; + ID_STATUS_FREECHAT: i:=psf_freechat; + ID_STATUS_OUTTOLUNCH: i:=psf_outtolunch; + ID_STATUS_ONTHEPHONE: i:=psf_onthephone; + else + exit; + end; + with protos^[ProtoNum] do + if state then + enabled:=enabled or i + else + enabled:=enabled and not i; + end; + +var + i:integer; + Item:TLVITEM; +begin + for i:=1 to ListView_GetItemCount(list)-1 do //skip default + begin + Item.iItem:=i; + Item.mask:=LVIF_PARAM; + ListView_GetItem(list,Item); + SetStatusMask(Item.lParam,ListView_GetCheckState(list,i)=BST_CHECKED) + end; +end; + +function CreateProtoList:integer; +var + protoCount,i:integer; + proto:^PPROTOCOLDESCRIPTOR; + buf:array [0..127] of AnsiChar; + flag:integer; + p:pAnsichar; +begin + CallService(MS_PROTO_ENUMPROTOCOLS,integer(@protoCount),dword(@proto)); + mGetMem(protos,(protoCount+1)*SizeOf(tMyProto)); // 0 - default + NumProto:=0; + with protos^[0] do + begin + name :=defproto; + status :=-1; + enabled:=-1; + end; + for i:=1 to protoCount do + begin + if proto^^._type=PROTOTYPE_PROTOCOL then + begin + inc(NumProto); + with protos^[NumProto] do + begin + name :=proto^^.szName; +// xstat :=-1; + enabled:=psf_all;//psf_enabled; + status :=0; + flag:=CallProtoService(name,PS_GETCAPS,PFLAGNUM_2,0); + if (flag and PF2_ONLINE) <>0 then status:=status or psf_online; + if (flag and PF2_INVISIBLE) <>0 then status:=status or psf_invisible; + if (flag and PF2_SHORTAWAY) <>0 then status:=status or psf_shortaway; + if (flag and PF2_LONGAWAY) <>0 then status:=status or psf_longaway; + if (flag and PF2_LIGHTDND) <>0 then status:=status or psf_lightdnd; + if (flag and PF2_HEAVYDND) <>0 then status:=status or psf_heavydnd; + if (flag and PF2_FREECHAT) <>0 then status:=status or psf_freechat; + if (flag and PF2_OUTTOLUNCH)<>0 then status:=status or psf_outtolunch; + if (flag and PF2_ONTHEPHONE)<>0 then status:=status or psf_onthephone; + + flag:=CallProtoService(name,PS_GETCAPS,PFLAGNUM_1,0); + if ((flag and PF1_CHAT)<>0) or + (DBReadByte(0,name,'CtcpChatAccept',13)<>13) or // IRC + (DBReadByte(0,name,'Jud',13)<>13) then // Jabber +// flag:=CallProtoService(name,PS_GETCAPS,PFLAGNUM_1,0); +// if (flag and PF1_CHAT)<>0 then + status:=status or psf_chat; + p:=StrCopyE(buf,name); + StrCopy(p,PS_ICQ_GETCUSTOMSTATUS); + if PluginLink^.ServiceExists(buf)<>0 then + status:=status or psf_icq; + + StrCopy(p,PS_SET_LISTENINGTO); + if PluginLink^.ServiceExists(buf)<>0 then + status:=status or psf_tunes; + + end; + end; + inc(proto); + end; + + if PluginLink^.ServiceExists(MS_NAS_SETSTATEA)<>0 then + NASPresents:=true + else + NASPresents:=false; + + result:=NumProto; +end; + +procedure FreeProtoList; +begin + mFreeMem(protos); + NumProto:=0; +end; + +function SetStatus(proto:PAnsiChar;status:integer;txt:PAnsiChar=pointer(-1)):integer; +var + nas:TNAS_PROTOINFO; +begin + if status>0 then + result:=CallProtoService(proto,PS_SETSTATUS,status,0) + else + result:=-1; + if integer(txt)<>-1 then + begin + if not NASPresents then + result:=CallProtoService(proto,PS_SETAWAYMSG,abs(status),dword(txt)) + else + begin + { + nas.Msg.w:=mmi.malloc((StrLenW(txt)+1)*SizeOf(WideChar)); + nas.Msg.w^:=#0; + StrCopyW(nas.Msg.w,txt); + } + StrDup(nas.Msg.a,txt); + nas.Flags :=0; + nas.cbSize :=SizeOf(nas); + nas.szProto:=proto; + nas.status :=abs(status){0}; + result:=PluginLink^.CallService(MS_NAS_SETSTATEA,LPARAM(@nas),1); + end; + end; +end; + +function SetXStatus(proto:PAnsiChar;newstatus:integer; + txt:pWideChar=nil;title:pWideChar=nil):integer; +var + ics:TICQ_CUSTOM_STATUS; +begin + result:=0; + if IsXStatusSupported(dword(proto)) then + begin + with ics do + begin + cbSize:=SizeOf(ics); + flags:=CSSF_UNICODE; + if newstatus>=0 then + begin + flags:=flags or CSSF_MASK_STATUS; + status:=@newstatus; + end; + if integer(title)<>-1 then + begin + flags:=flags or CSSF_MASK_NAME; + szName.w:=title; + end; + if integer(title)<>-1 then + begin + flags:=flags or CSSF_MASK_MESSAGE; + szMessage.w:=txt; + end; + end; + result:=CallProtoService(proto,PS_ICQ_SETCUSTOMSTATUSEX,0,dword(@ics)); + end; +end; + +function GetXStatus(proto:PAnsiChar;txt:pointer=nil;title:pointer=nil):integer; +var + buf:array [0..127] of AnsiChar; + pc:PAnsiChar; + param:array [0..63] of AnsiChar; + +// ics:TICQ_CUSTOM_STATUS; +// i,j:integer; +begin + result:=0; + if IsXStatusSupported(dword(proto)) then + begin +{ + with ics do + begin + cbSize:=SizeOf(ics); + flags:=CSSF_STR_SIZES; + wParam:=@i; + lParam:=@j; + end; + CallProtoService(0,PS_ICQ_GETCUSTOMSTATUSEX,0,dword(@ics)); + if title<>nil then + mGetMem(title^,(i+1)*SizeOf(WideChar)); + if txt<>nil then + mGetMem(txt^,(j+1)*SizeOf(WideChar)); + + with ics do + begin + cbSize:=SizeOf(ics); + flags:=CSSF_MASK_STATUS or CSSF_MASK_NAME or CSSF_MASK_MESSAGE or CSSF_UNICODE; + status:=@result; + szName.w :=pdword(title)^; + szMessage.w:=pdword(txt)^; + end; + CallProtoService(0,PS_ICQ_GETCUSTOMSTATUSEX,0,dword(@ics)); +} + + StrCopy(buf,proto); + StrCat (buf,PS_ICQ_GETCUSTOMSTATUS); + result:=PluginLink^.CallService(buf,0,0); + if (txt<>nil) or (title<>nil) then + begin + move('XStatus',param,7); + IntToStr(param+7,result); + pc:=strend(param); + + if txt<>nil then + begin + StrCopy(pc,'Msg'); pWideChar(txt^):=DBReadUnicode(0,proto,param,nil); + end; + if title<>nil then + begin + StrCopy(pc,'Name'); pWideChar(title^):=DBReadUnicode(0,proto,param,nil); + end; + end; + + end; +end; + +end. diff --git a/delphi/Awkward/utils/syswin.pas b/delphi/Awkward/utils/syswin.pas new file mode 100644 index 0000000..d22700e --- /dev/null +++ b/delphi/Awkward/utils/syswin.pas @@ -0,0 +1,734 @@ +unit SysWin; +{$include compilers.inc} + +interface + +uses windows; + +type + FFWFilterProc = function(fname:pWideChar):boolean; + +const + ThreadTimeout = 50; +const + gffdMultiThread = 1; + gffdOld = 2; + +function GetWorkOfflineStatus:integer; + +function ExecuteWaitW(AppPath:pWideChar; CmdLine:pWideChar=nil; DfltDirectory:PWideChar=nil; + Show:DWORD=SW_SHOWNORMAL; TimeOut:DWORD=0; ProcID:PDWORD=nil):dword; +function ExecuteWait(AppPath:PAnsiChar; CmdLine:PAnsiChar=nil; DfltDirectory:PAnsiChar=nil; + Show:DWORD=SW_SHOWNORMAL; TimeOut:DWORD=0; ProcID:PDWORD=nil):dword; + +function SendString(wnd:HWND;astr:PWideChar):integer; overload; +function SendString(wnd:HWND;astr:PAnsiChar):integer; overload; +procedure ProcessMessages; +function GetFocusedChild(wnd:HWND):HWND; +function GetAssoc(key:PAnsiChar):PAnsiChar; +function GetEXEbyWnd(w:HWND; var dst:pWideChar):pWideChar; overload; +function GetEXEbyWnd(w:HWND; var dst:PAnsiChar):PAnsiChar; overload; +function IsExeRunning(exename:PWideChar):boolean; {hwnd} +function GetFileFromWnd(wnd:HWND;Filter:FFWFilterProc; + flags:dword=gffdMultiThread+gffdOld):pWideChar; + +function WaitFocusedWndChild(Wnd:HWnd):HWnd; + +implementation + +uses shellapi,PSAPI,common,messages; + +function GetWorkOfflineStatus:integer; +var + lKey:HKEY; + len,typ:dword; +begin + result:=0; + if RegOpenKeyEx(HKEY_CURRENT_USER, + 'Software\Microsoft\Windows\CurrentVersion\Internet Settings',0, + KEY_READ,lKey)=ERROR_SUCCESS then + begin + len:=4; + typ:=REG_DWORD; + if RegQueryValueEx(lKey,'GlobalUserOffline',NIL,@typ,@result,@len)=ERROR_SUCCESS then + ; + RegCloseKey(lKey); + end; +end; + +function ExecuteWaitW(AppPath:pWideChar; CmdLine:pWideChar=nil; DfltDirectory:PWideChar=nil; + Show:DWORD=SW_SHOWNORMAL; TimeOut:DWORD=0; ProcID:PDWORD=nil):dword; +var + Flags: DWORD; + Startup: {$IFDEF DELPHI10_UP}TStartupInfoW{$ELSE}TStartupInfo{$ENDIF}; + ProcInf: TProcessInformation; + App: array [0..1023] of widechar; + p:PWideChar; + ext1,ext2:array [0..7] of widechar; +begin + Result := cardinal(-1); + if FindExecutableW(AppPath,DfltDirectory,App)<=32 then + exit; + if lstrcmpiw(GetExt(AppPath,ext1,7),GetExt(App,ext2,7))<>0 then + CmdLine:=AppPath; + Flags := CREATE_NEW_CONSOLE; + if Show = SW_HIDE then + Flags := Flags or CREATE_NO_WINDOW; + FillChar(Startup, SizeOf(Startup),0); + with Startup do + begin + cb :=SizeOf(Startup); + wShowWindow:=Show; + dwFlags :=STARTF_USESHOWWINDOW; + end; + if ProcID <> nil then + ProcID^ := 0; + p:=StrEndW(App); + if (CmdLine<>nil) and (CmdLine^<>#0) then + begin + p^:=' '; + inc(p); + StrCopyW(p,CmdLine); + end; + if CreateProcessW(nil,App,nil,nil,FALSE,Flags,nil,DfltDirectory,Startup,ProcInf) then + begin + if TimeOut<>0 then + begin + if WaitForSingleObject(ProcInf.hProcess,TimeOut)=WAIT_OBJECT_0 then + begin + GetExitCodeProcess(ProcInf.hProcess,result); + CloseHandle(ProcInf.hProcess); + end + else + begin + result:=1; + if ProcID<>nil then + ProcID^:=ProcInf.hProcess; + end; + end + else + begin + GetExitCodeProcess(ProcInf.hProcess,result); + CloseHandle(ProcInf.hProcess); + end; + CloseHandle(ProcInf.hThread); + end; +end; + +function ExecuteWait(AppPath:PAnsiChar; CmdLine:PAnsiChar=nil; DfltDirectory:PAnsiChar=nil; + Show:DWORD=SW_SHOWNORMAL; TimeOut:DWORD=0; ProcID:PDWORD=nil):dword; +var + Flags: DWORD; + Startup: {$IFDEF DELPHI10_UP}TStartupInfoA{$ELSE}TStartupInfo{$ENDIF}; +// Startup: TStartupInfoA; + ProcInf: TProcessInformation; + App: array [0..1023] of AnsiChar; + p:PAnsiChar; + ext1,ext2:array [0..7] of AnsiChar; +begin + Result := cardinal(-1); + if FindExecutableA(AppPath,DfltDirectory,App)<=32 then + exit; + if lstrcmpia(GetExt(AppPath,ext1,7),GetExt(App,ext2,7))<>0 then + CmdLine:=AppPath; + Flags := CREATE_NEW_CONSOLE; + if Show = SW_HIDE then + Flags := Flags or CREATE_NO_WINDOW; + FillChar(Startup, SizeOf(Startup),0); + with Startup do + begin + cb :=SizeOf(Startup); + wShowWindow:=Show; + dwFlags :=STARTF_USESHOWWINDOW; + end; + if ProcID <> nil then + ProcID^ := 0; + p:=StrEnd(App); + if (CmdLine<>nil) and (CmdLine^<>#0) then + begin + p^:=' '; + inc(p); + StrCopy(p,CmdLine); + end; + if CreateProcessA(nil,App,nil,nil,FALSE,Flags,nil,DfltDirectory,Startup,ProcInf) then + begin + if TimeOut<>0 then + begin + if WaitForSingleObject(ProcInf.hProcess,TimeOut)=WAIT_OBJECT_0 then + begin + GetExitCodeProcess(ProcInf.hProcess,result); + CloseHandle(ProcInf.hProcess); + end + else + begin + result:=1; + if ProcID<>nil then + ProcID^:=ProcInf.hProcess; + end; + end + else + begin + GetExitCodeProcess(ProcInf.hProcess,result); + CloseHandle(ProcInf.hProcess); + end; + CloseHandle(ProcInf.hThread); + end; +end; + +function WaitFocusedWndChild(Wnd:HWnd):HWnd; +var + T1,T2:Integer; + W:HWnd; +begin + Sleep(50); + T1:=GetTickCount; + repeat + W:=GetTopWindow(Wnd); + if W=0 then W:=Wnd; + W:=GetFocusedChild(W); + if W<>0 then + begin + Wnd:=W; + break; + end; + T2:=GetTickCount; + if Abs(T1-T2)>100 then break; + until false; + Result:=Wnd; +end; + +function SendString(wnd:HWND;astr:PWideChar):integer; +var + s,s0:PWideChar; + style:integer; +begin + result:=0; + if (astr=nil) or (astr^=#0) then exit; + if wnd=0 then + begin + wnd:=WaitFocusedWndChild(GetForegroundWindow); + if wnd=0 then Exit; + end; + style:=GetWindowLongW(wnd,GWL_STYLE); + if (style and (WS_DISABLED or ES_READONLY))=0 then + begin + StrDupW(s,astr); //?? + s0:=s; + while s^<>#0 do + begin + if s^<>#10 then + PostMessageW(Wnd,WM_CHAR,ord(s^),1); + Inc(s); + end; + mFreeMem(s0); //?? + result:=1; + end; +end; + +function SendString(wnd:HWND;astr:PAnsiChar):integer; +var + s,s0:PAnsiChar; + style:integer; +begin + result:=0; + if (astr=nil) or (astr^=#0) then exit; + if wnd=0 then + begin + wnd:=WaitFocusedWndChild(GetForegroundWindow); + if wnd=0 then Exit; + end; + style:=GetWindowLongA(wnd,GWL_STYLE); + if (style and (WS_DISABLED or ES_READONLY))=0 then + begin + StrDup(s,astr); //?? + s0:=s; + while s^<>#0 do + begin + if s^<>#10 then + PostMessageA(Wnd,WM_CHAR,ord(s^),1); + Inc(s); + end; + mFreeMem(s0); //?? + result:=1; + end; +end; + +procedure ProcessMessages; +var + Unicode: Boolean; + MsgExists: Boolean; + Msg:TMsg; +begin + repeat + if PeekMessageA(Msg,0,0,0,PM_NOREMOVE) then + begin + Unicode:=(Msg.hwnd<>0) and IsWindowUnicode(Msg.hwnd); + if Unicode then + MsgExists:=PeekMessageW(Msg,0,0,0,PM_REMOVE) + else + MsgExists:=PeekMessageA(Msg,0,0,0,PM_REMOVE); + if not MsgExists then break; + + if Msg.Message<>WM_QUIT then + begin + TranslateMessage(Msg); + if Unicode then + DispatchMessageW(Msg) + else + DispatchMessageA(Msg); + end; + end + else + break; + until false; +end; + +function GetFocusedChild(wnd:HWND):HWND; +var + dwTargetOwner:DWORD; + dwThreadID:DWORD; + res:boolean; +begin + dwTargetOwner:=GetWindowThreadProcessId(wnd,nil); + dwThreadID:=GetCurrentThreadId(); + res:=false; + if (dwTargetOwner<>dwThreadID) then + res:=AttachThreadInput(dwThreadID,dwTargetOwner,TRUE); + result:=GetFocus; + if res then + AttachThreadInput(dwThreadID,dwTargetOwner,FALSE); +end; + +function GetAssoc(key:PAnsiChar):PAnsiChar; +var + lKey:HKEY; + tmpbuf:array [0..511] of AnsiChar; + len:integer; +begin + result:=nil; + if RegOpenKeyExA(HKEY_CLASSES_ROOT,key,0, + KEY_READ,lKey)=ERROR_SUCCESS then + begin + len:=511; + if (RegQueryValueExA(lKey,NIL,NIL,NIL,@tmpbuf,@len)=ERROR_SUCCESS) then + begin + StrDup(result,tmpbuf); +// only path +// while result[len]<>'\' do dec(len); +// StrCopy(result,result+2,len-3); + end; + RegCloseKey(lKey); + end; +end; + +type + TThreadInfo = record + ftCreationTime:TFileTime; + dwUnknown1:dword; + dwStartAddress:dword; + dwOwningPID:dword; + dwThreadID:dword; + dwCurrentPriority:dword; + dwBasePriority:dword; + dwContextSwitches:dword; + dwThreadState:dword; + dwUnknown2:dword; + dwUnknown3:dword; + dwUnknown4:dword; + dwUnknown5:dword; + dwUnknown6:dword; + dwUnknown7:dword; + end; + + TProcessInfo = record + dwOffset:dword; + dwThreadCount:dword; + dwUnknown1:array[0..5] of dword; + ftCreationTime:TFileTime; + ftUserTime:int64; + ftKernelTime:int64; + wLength:word; + wMaximumLength:word; + pszProcessName:pWideChar; + dwBasePriority:dword; + dwProcessID:dword; + dwParentProcessID:dword; + dwHandleCount:dword; +// not interesting + dwUnknown7:dword; + dwUnknown8:dword; + dwVirtualBytesPeak:dword; + dwVirtualBytes:dword; + dwPageFaults:dword; + dwWorkingSetPeak:dword; + dwWorkingSet:dword; + dwUnknown9:dword; + dwPagedPool:dword; + dwUnknown10:dword; + dwNonPagedPool:dword; + dwPageFileBytesPeak:dword; + dwPageFileBytes:dword; + dwPrivateBytes:dword; + dwUnknown11:dword; + dwUnknown12:dword; + dwUnknown13:dword; + dwUnknown14:dword; + ati:array[0..0] of TThreadInfo; + end; + +function NtQuerySystemInformation(si_class:cardinal;si:pointer;si_length:cardinal;ret_length:cardinal):cardinal; stdcall; external 'ntdll.dll'; +function NtQueryObject(ObjectHandle:THANDLE;ObjectInformationClass:dword;ObjectInformation:pointer;Length:dword;var ResultLength:dword):cardinal; stdcall; external 'ntdll.dll'; +const + ObjectNameInformation = 1; // +4 bytes + ObjectTypeInformation = 2; // +$60 bytes +const + STATUS_INFO_LENGTH_MISMATCH = $C0000004; + +function GetHandleCount(pid:dword):dword; +var + buf:pointer; + pi:^TProcessInfo; +begin +{BOOL GetProcessHandleCount( + HANDLE hProcess, + PDWORD pdwHandleCount +} + mGetMem(buf,300000); + NtQuerySystemInformation(5, buf, 300000, 0); + pi:=buf; + result:=0; + repeat + pi:=pointer(cardinal(pi)+pi^.dwOffset); //first - Idle process + if pi^.dwProcessID=pid then + begin + result:=pi^.dwHandleCount; + break; + end; + if pi^.dwOffset=0 then + break; + until false; + mFreeMem(buf); +end; + +function GetEXEbyWnd(w:HWND; var dst:pWideChar):pWideChar; +var + hProcess:THANDLE; + ProcID:DWORD; + ModuleName: array [0..300] of WideChar; +begin + dst:=nil; + GetWindowThreadProcessId(w,@ProcID); + if ProcID<>0 then + begin + hProcess:=OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,False,ProcID); + if hProcess<>0 then + begin + ModuleName[0]:=#0; + GetModuleFilenameExW(hProcess,0,ModuleName,SizeOf(ModuleName)); + StrDupW(dst,ModuleName); + CloseHandle(hProcess); + end; + end; + result:=dst; +end; + +function GetEXEbyWnd(w:HWND; var dst:PAnsiChar):PAnsiChar; +var + hProcess:THANDLE; + ProcID:DWORD; + ModuleName: array [0..300] of AnsiChar; +begin + dst:=nil; + GetWindowThreadProcessId(w,@ProcID); + if ProcID<>0 then + begin + hProcess:=OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,False,ProcID); + if hProcess<>0 then + begin + ModuleName[0]:=#0; + GetModuleFilenameExA(hProcess,0,ModuleName,SizeOf(ModuleName)); + StrDup(dst,ModuleName); + CloseHandle(hProcess); + end; + end; + result:=dst; +end; + +function IsExeRunning(exename:PWideChar):boolean;{hwnd} +const + nCount = 4096; +var + Processes:array [0..nCount-1] of dword; + nProcess:dword; + hProcess:THANDLE; + ModuleName: array [0..300] of WideChar; + i:integer; +begin + result:=false; + EnumProcesses(pointer(@Processes),nCount*SizeOf(DWORD),nProcess); + nProcess:=(nProcess div 4)-1; + for i:=2 to nProcess do //skip Idle & System + begin + hProcess:=OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, + False,Processes[i]); + if hProcess<>0 then + begin + GetModuleFilenameExW(hProcess,0,ModuleName,SizeOf(ModuleName)); + result:=lstrcmpiw(extractw(ModuleName,true),exename)=0; + CloseHandle(hProcess); + if result then exit; + end; + end; +end; + +function TranslatePath(fn:PWideChar):PWideChar; +const + LANPrefix:PWideChar = '\Device\LanmanRedirector\'; +var + szTemp:array [0..511] of WideChar; + szName:array [0..511] of WideChar; + p:PWideChar; + uNameLen:word; + szTempFile:array [0..511] of WideChar; +begin + if StrPosW(fn,LANPrefix)=fn then + begin + uNameLen:=StrLenW(LANPrefix); + mGetMem(result,(StrLenW(fn)-uNameLen+3)*SizeOf(WideChar)); + result[0]:='\'; + result[1]:='\'; + StrCopyW(result+2,fn+uNameLen); + exit; + end; + if GetLogicalDriveStringsW(255,@szTemp)<>0 then + begin + p:=szTemp; + repeat + p[2]:=#0; + if QueryDosDeviceW(p,szName,255)<>0 then + begin + uNameLen:=StrLenW(szName)+1; + if uNameLen<255 then + begin + StrCopyW(szTempFile,fn,uNameLen-1); + if lstrcmpiw(szTempFile,szName)=0 then + begin + mGetMem(result,(StrLenW(fn+uNameLen)+4)*SizeOf(WideChar)); + result[0]:=WideChar(ORD(p[0])); + result[1]:=':'; + result[2]:='\'; + StrCopyW(result+3,fn+uNameLen); + exit; + end; + end; + end; + inc(p,4); + until p^=#0; + end; + StrDupW(result,fn); +end; + +const + maxhandles = 15; +var + har,hold:array [0..maxhandles-1] of PWideChar; + harcnt:integer; +const + oldcnt:integer=0; + +procedure ArSwitch(idx:integer); +var + j:integer; + h:pWideChar; +begin +//clear old + j:=0; + while j0 then + begin + h :=hold[idx]; + hold[idx]:=hold[0]; + hold[0] :=h; + end; +end; + +function CheckHandles(ReturnNew:bool):integer; +var + i,j:integer; + flg:boolean; +begin + result:=0; + if oldcnt=0 then //first time + begin + ArSwitch(0); + exit; + end; + i:=0; + if ReturnNew then + begin + while i0) or + (StrCmpW(TmpBuf+$30,'File')<>0) then + Exit; + + rec.handle:=Handle; + rec.fname:=nil; + + if not MultiThread then + begin + GetName(@rec); + result:=rec.fname; + end + else + begin + hThread:=BeginThread(nil,0,@GetName,@rec,0,pdword(nil)^); + if WaitForSingleObject(hThread,ThreadTimeout)=WAIT_TIMEOUT then + begin + TerminateThread(hThread,0); + end + else + result:=rec.fname; + CloseHandle(hThread); + end; +end; + +function GetFileFromWnd(wnd:HWND;Filter:FFWFilterProc; + flags:dword=gffdMultiThread+gffdOld):pWideChar; +var + hProcess,h:THANDLE; + pid:dword; + i:cardinal; + c:thandle; + Handles:dword; + pc:pWideChar; +begin + result:=nil; + i:=4; + GetWindowThreadProcessId(wnd,@c); + pid:=OpenProcess(PROCESS_DUP_HANDLE,true,c); + Handles:=GetHandleCount(c)*4; + harcnt:=0; + hProcess:=GetCurrentProcess; + + while true do + begin + if DuplicateHandle(pid,i,hProcess,@h,GENERIC_READ,false,0) then + begin + pc:=TestHandle(h,(flags and gffdMultiThread)<>0); + if pc<>nil then + begin +// if GetFileType(h)=FILE_TYPE_DISK then + begin + if (@Filter=nil) or Filter(pc) and (harcntMaxHandle then break; //file not found + end; + inc(i,4); + if i>Handles then + break; + end; + + CloseHandle(pid); + if harcnt>0 then + begin + CheckHandles((flags and gffdOld)=0); + result:=translatePath(hold[0]); + end +end; + +end. diff --git a/delphi/Awkward/utils/utils.pas b/delphi/Awkward/utils/utils.pas new file mode 100644 index 0000000..8c16e03 --- /dev/null +++ b/delphi/Awkward/utils/utils.pas @@ -0,0 +1,44 @@ +unit Utils; + +interface + +uses windows; + +function SaveTemporaryW(ptr:pointer;size:dword;ext:PWideChar=nil):pWideChar; +function SaveTemporary (ptr:pointer;size:dword;ext:PAnsiChar=nil):PAnsiChar; + +implementation + +uses common,io; + +function SaveTemporaryW(ptr:pointer;size:dword;ext:PWideChar=nil):pWideChar; +var + buf,buf1:array [0..MAX_PATH-1] of WideChar; + f:THANDLE; +begin + GetTempPathW(MAX_PATH,buf); + GetTempFileNameW(buf,'wat',GetCurrentTime,buf1); + ChangeExtW(buf1,ext); + + f:=ReWrite(buf1); + BlockWrite(f,pByte(ptr)^,size); + CloseHandle(f); + StrDupW(result,buf1); +end; + +function SaveTemporary(ptr:pointer;size:dword;ext:PAnsiChar=nil):PAnsiChar; +var + buf,buf1:array [0..MAX_PATH-1] of AnsiChar; + f:THANDLE; +begin + GetTempPathA(SizeOf(buf),buf); + GetTempFileNameA(buf,'wat',GetCurrentTime,buf1); + ChangeExt(buf1,ext); + + f:=ReWrite(buf1); + BlockWrite(f,pByte(ptr)^,size); + CloseHandle(f); + StrDup(result,buf1); +end; + +end. \ No newline at end of file diff --git a/delphi/Awkward/utils/wrapper.pas b/delphi/Awkward/utils/wrapper.pas new file mode 100644 index 0000000..c7b4d05 --- /dev/null +++ b/delphi/Awkward/utils/wrapper.pas @@ -0,0 +1,450 @@ +{$include compilers.inc} +unit wrapper; + +interface +uses windows; + +function GetScreenRect():TRect; +procedure SnapToScreen(var rc:TRect;dx:integer=0;dy:integer=0{; + minw:integer=240;minh:integer=100}); + +function LV_GetLParam (list:HWND;item:integer=-1):integer; +function LV_SetLParam (list:HWND;lParam:dword;item:integer=-1):integer; +function LV_ItemAtPos(wnd:HWND;Pt:TPOINT;var SubItem:dword):Integer; overload; +function LV_ItemAtPos(wnd:HWND;x,y:integer;var SubItem:dword):Integer; overload; +procedure LV_SetItem (handle:hwnd;str:PAnsiChar;item:integer;subitem:integer=0); +procedure LV_SetItemW(handle:hwnd;str:PWideChar;item:integer;subitem:integer=0); +function LV_MoveItem(list:hwnd;direction:integer;item:integer=-1):integer; +function LV_GetColumnCount(list:HWND):integer; +function LV_CheckDirection(list:HWND):integer; // bit 0 - can move up, bit 1 - down + +function GetDlgText(Dialog:HWND;idc:integer;getAnsi:boolean=false):pointer; overload; +function GetDlgText(wnd:HWND;getAnsi:boolean=false):pointer; overload; +function ShowDlg (dst:PAnsiChar;fname:PAnsiChar=nil;Filter:PAnsiChar=nil;open:boolean=true):boolean; +function ShowDlgW(dst:PWideChar;fname:PWideChar=nil;Filter:PWideChar=nil;open:boolean=true):boolean; + +function SelectDirectory(Caption:PAnsiChar;var Directory:PAnsiChar; + Parent:HWND=0;newstyle:bool=false):Boolean; overload; +function SelectDirectory(Caption:PWideChar;var Directory:PWideChar; + Parent:HWND=0;newstyle:bool=false):Boolean; overload; + +function CB_SelectData(cb:HWND;data:dword):integer; overload; +function CB_SelectData(Dialog:HWND;id:cardinal;data:dword):integer; overload; +function CB_GetData (cb:HWND;idx:integer=-1):dword; +function CB_AddStrData (cb:HWND;astr:pAnsiChar;data:integer=0;idx:integer=-1):HWND; +function CB_AddStrDataW(cb:HWND;astr:pWideChar;data:integer=0;idx:integer=-1):HWND; + +implementation +uses messages,common,shlobj,activex,commctrl,commdlg; + +{.$IFNDEF DELPHI10_UP} +const + LVM_SORTITEMSEX = LVM_FIRST + 81; +{.$ENDIF} +{$IFNDEF DELPHI7_UP} +const + BIF_NEWDIALOGSTYLE = $0040; +const + SM_XVIRTUALSCREEN = 76; + SM_YVIRTUALSCREEN = 77; + SM_CXVIRTUALSCREEN = 78; + SM_CYVIRTUALSCREEN = 79; +{$ENDIF} + +function GetScreenRect():TRect; +begin + result.left := GetSystemMetrics( SM_XVIRTUALSCREEN ); + result.top := GetSystemMetrics( SM_YVIRTUALSCREEN ); + result.right := GetSystemMetrics( SM_CXVIRTUALSCREEN ) + result.left; + result.bottom:= GetSystemMetrics( SM_CYVIRTUALSCREEN ) + result.top; +end; + +procedure SnapToScreen(var rc:TRect;dx:integer=0;dy:integer=0{; + minw:integer=240;minh:integer=100}); +var + rect:TRect; +begin + rect:=GetScreenRect; + if rc.right >rect.right then rc.right :=rect.right -dx; + if rc.bottom>rect.bottom then rc.bottom:=rect.bottom-dy; + if rc.left 1 then + begin + mGetMem(PAnsiChar(result),a); + SendMessageA(wnd,WM_GETTEXT,a,longint(result)); + end; + end + else + begin + a:=SendMessageW(wnd,WM_GETTEXTLENGTH,0,0)+1; + if a>1 then + begin + mGetMem(pWideChar(result),a*SizeOf(WideChar)); + SendMessageW(wnd,WM_GETTEXT,a,longint(result)); + end; + end; +end; + +function GetDlgText(Dialog:HWND;idc:integer;getAnsi:boolean=false):pointer; +begin + result:=GetDlgText(GetDlgItem(Dialog,idc),getAnsi); +end; + +function ShowDlg(dst:PAnsiChar;fname:PAnsiChar=nil;Filter:PAnsiChar=nil;open:boolean=true):boolean; +var + NameRec:OpenFileNameA; +begin + FillChar(NameRec,SizeOf(NameRec),0); + with NameRec do + begin + LStructSize:=SizeOf(NameRec); + if fname=nil then + dst[0]:=#0 + else if fname<>dst then + StrCopy(dst,fname); +// lpstrInitialDir:=dst; + lpStrFile :=dst; + lpStrFilter:=Filter; + if Filter<>nil then + begin + lpstrDefExt:=StrEnd(Filter)+1; + inc(lpstrDefExt,2); // skip "*." + end; + NMaxFile :=511; + Flags :=OFN_EXPLORER or OFN_OVERWRITEPROMPT;// or OFN_HIDEREADONLY; + end; + if open then + result:=GetOpenFileNameA(NameRec) + else + result:=GetSaveFileNameA(NameRec); +end; + +function ShowDlgW(dst:PWideChar;fname:PWideChar=nil;Filter:PWideChar=nil;open:boolean=true):boolean; +var + NameRec:OpenFileNameW; +begin + FillChar(NameRec,SizeOf(NameRec),0); + with NameRec do + begin + LStructSize:=SizeOf(NameRec); + if fname=nil then + dst[0]:=#0 + else if fname<>dst then + StrCopyW(dst,fname); +// lpstrInitialDir:=dst; + lpStrFile :=dst; + lpStrFilter:=Filter; + if Filter<>nil then + begin + lpstrDefExt:=StrEndW(Filter)+1; + inc(lpstrDefExt,2); // skip "*." + end; + NMaxFile :=511; + Flags :=OFN_EXPLORER or OFN_OVERWRITEPROMPT;// or OFN_HIDEREADONLY; + end; + if open then + result:=GetOpenFileNameW(NameRec) + else + result:=GetSaveFileNameW(NameRec) +end; + +procedure LV_SetItem(handle:hwnd;str:PAnsiChar;item:integer;subitem:integer=0); +var + li:LV_ITEMA; +begin +// zeromemory(@li,sizeof(li)); + li.mask :=LVIF_TEXT; + li.pszText :=str; + li.iItem :=item; + li.iSubItem:=subitem; + SendMessageA(handle,LVM_SETITEMA,0,integer(@li)); +end; + +procedure LV_SetItemW(handle:hwnd;str:PWideChar;item:integer;subitem:integer=0); +var + li:LV_ITEMW; +begin +// zeromemory(@li,sizeof(li)); + li.mask :=LVIF_TEXT; + li.pszText :=str; + li.iItem :=item; + li.iSubItem:=subitem; + SendMessageW(handle,LVM_SETITEMW,0,integer(@li)); +end; + +function SelectDirectory(Caption:PAnsiChar;var Directory:PAnsiChar; + Parent:HWND=0;newstyle:bool=false):Boolean; +var + BrowseInfo:TBrowseInfoA; + Buffer:array [0..MAX_PATH-1] of AnsiChar; + ItemIDList:PItemIDList; + ShellMalloc:IMalloc; +begin + Result:=False; + FillChar(BrowseInfo,SizeOf(BrowseInfo),0); + if (ShGetMalloc(ShellMalloc)=S_OK) and (ShellMalloc<>nil) then + begin + with BrowseInfo do + begin + hwndOwner :=Parent; + pszDisplayName:=Buffer; + lpszTitle :=Caption; + ulFlags :=BIF_RETURNONLYFSDIRS; + end; + if newstyle then + if CoInitializeEx(nil,COINIT_APARTMENTTHREADED)<>RPC_E_CHANGED_MODE then + BrowseInfo.ulFlags:=BrowseInfo.ulFlags or BIF_NEWDIALOGSTYLE; + try + ItemIDList:=ShBrowseForFolderA(BrowseInfo); + Result:=ItemIDList<>nil; + if Result then + begin + ShGetPathFromIDListA(ItemIDList,Buffer); + StrDup(Directory,Buffer); + ShellMalloc.Free(ItemIDList); + end; + finally + if newstyle then CoUninitialize; + end; + end; +end; + +function SelectDirectory(Caption:PWideChar;var Directory:PWideChar; + Parent:HWND=0;newstyle:bool=false):Boolean; +var + BrowseInfo:TBrowseInfoW; + Buffer:array [0..MAX_PATH-1] of WideChar; + ItemIDList:PItemIDList; + ShellMalloc:IMalloc; +begin + Result:=False; + FillChar(BrowseInfo,SizeOf(BrowseInfo),0); + if (ShGetMalloc(ShellMalloc)=S_OK) and (ShellMalloc<>nil) then + begin + with BrowseInfo do + begin + hwndOwner :=Parent; + pszDisplayName:=Buffer; + lpszTitle :=Caption; + ulFlags :=BIF_RETURNONLYFSDIRS; + end; + if newstyle then + if CoInitializeEx(nil,COINIT_APARTMENTTHREADED)<>RPC_E_CHANGED_MODE then + BrowseInfo.ulFlags:=BrowseInfo.ulFlags or BIF_NEWDIALOGSTYLE; + try + ItemIDList:=ShBrowseForFolderW(BrowseInfo); + Result:=ItemIDList<>nil; + if Result then + begin + ShGetPathFromIDListW(ItemIDList,Buffer); + StrDupW(Directory,Buffer); + ShellMalloc.Free(ItemIDList); + end; + finally + if newstyle then CoUninitialize; + end; + end; +end; + +//----- ListView functions ----- + +function LV_GetLParam(list:HWND;item:integer=-1):integer; +var + li:LV_ITEMW; +begin + if item<0 then + begin + item:=SendMessage(list,LVM_GETNEXTITEM,-1,LVNI_FOCUSED); + if item<0 then + begin + result:=-1; + exit; + end; + end; + li.iItem :=item; + li.mask :=LVIF_PARAM; + li.iSubItem:=0; + SendMessageW(list,LVM_GETITEMW,0,dword(@li)); + result:=li.lParam; +end; + +function LV_SetLParam(list:HWND;lParam:dword;item:integer=-1):integer; +var + li:LV_ITEMW; +begin + if item<0 then + begin + item:=SendMessage(list,LVM_GETNEXTITEM,-1,LVNI_FOCUSED); + if item<0 then + begin + result:=-1; + exit; + end; + end; + li.iItem :=item; + li.mask :=LVIF_PARAM; + li.lParam :=lParam; + li.iSubItem:=0; + SendMessageW(list,LVM_SETITEMW,0,dword(@li)); + result:=lParam; +end; + +function LV_ItemAtPos(wnd:HWND;Pt:TPOINT;var SubItem:dword):Integer; +var + HTI:LV_HITTESTINFO; +begin + HTI.pt.x := Pt.X; + HTI.pt.y := Pt.Y; + SendMessage(wnd,LVM_SUBITEMHITTEST,0,Integer(@HTI)); + Result :=HTI.iItem; + if @SubItem<>nil then + SubItem:=HTI.iSubItem; +end; + +function LV_ItemAtPos(wnd:HWND;x,y:integer;var SubItem:dword):Integer; overload; +var + HTI:LV_HITTESTINFO; +begin + HTI.pt.x := x; + HTI.pt.y := y; + SendMessage(wnd,LVM_SUBITEMHITTEST,0,Integer(@HTI)); + Result :=HTI.iItem; + if @SubItem<>nil then + SubItem:=HTI.iSubItem; +end; + +function LV_Compare(lParam1,lParam2,param:LPARAM):integer; stdcall; +var + olditem,neibor:integer; +begin + result:=lParam1-lParam2; + neibor :=hiword(param); + olditem:=loword(param); + if neibor>olditem then + begin + if (lParam1=olditem) and (lParam2<=neibor) then + result:=1; + end + else + begin + if (lParam2=olditem) and (lParam1>=neibor) then + result:=1; + end; +end; + +function LV_MoveItem(list:hwnd;direction:integer;item:integer=-1):integer; +begin + if ((direction>0) and (item=(SendMessage(list,LVM_GETITEMCOUNT,0,0)-1))) or + ((direction<0) and (item=0)) then + begin + result:=item; + exit; + end; + + if item<0 then + item:=SendMessage(list,LVM_GETNEXTITEM,-1,LVNI_FOCUSED); + SendMessageW(list,LVM_SORTITEMSEX,dword(item)+(dword(item+direction) shl 16),dword(@LV_Compare)); + result:=item+direction; +end; + +function LV_GetColumnCount(list:HWND):integer; +begin + result:=SendMessage(SendMessage(list,LVM_GETHEADER,0,0),HDM_GETITEMCOUNT,0,0); +end; + +function LV_CheckDirection(list:HWND):integer; +var + i,cnt{,selcnt}:integer; + stat,first,last,focus: integer; +begin + first :=-1; + last :=-1; + focus :=-1; + cnt :=SendMessage(list,LVM_GETITEMCOUNT,0,0)-1; +// selcnt:=SendMessage(list,LVM_GETSELECTEDCOUNT,0,0); + for i:=0 to cnt do + begin + stat:=SendMessage(list,LVM_GETITEMSTATE,i,LVIS_SELECTED or LVIS_FOCUSED); + if (stat and LVIS_SELECTED)<>0 then + begin + if (stat and LVIS_FOCUSED)<>0 then + focus:=i; + if first<0 then first:=i; + last:=i; + end; + end; + result:=0; + if focus<0 then + focus:=first; + if focus>=0 then + result:=result or ((focus+1) shl 16); + if first>0 then // at least one selected and not first + begin + result:=(result or 1){ or (first+1) shl 16}; + end; + if (last>=0) and (last