diff options
Diffstat (limited to 'delphi/Awkward/utils')
| -rw-r--r-- | delphi/Awkward/utils/appcmdapi.pas | 97 | ||||
| -rw-r--r-- | delphi/Awkward/utils/base64.pas | 108 | ||||
| -rw-r--r-- | delphi/Awkward/utils/cbex.pas | 79 | ||||
| -rw-r--r-- | delphi/Awkward/utils/common.pas | 2116 | ||||
| -rw-r--r-- | delphi/Awkward/utils/compilers.inc | 735 | ||||
| -rw-r--r-- | delphi/Awkward/utils/dbsettings.pas | 421 | ||||
| -rw-r--r-- | delphi/Awkward/utils/hotkeys.pas | 571 | ||||
| -rw-r--r-- | delphi/Awkward/utils/ini.pas | 857 | ||||
| -rw-r--r-- | delphi/Awkward/utils/io.pas | 249 | ||||
| -rw-r--r-- | delphi/Awkward/utils/mirutils.pas | 1026 | ||||
| -rw-r--r-- | delphi/Awkward/utils/playlist.pas | 431 | ||||
| -rw-r--r-- | delphi/Awkward/utils/protocols.pas | 573 | ||||
| -rw-r--r-- | delphi/Awkward/utils/syswin.pas | 734 | ||||
| -rw-r--r-- | delphi/Awkward/utils/utils.pas | 44 | ||||
| -rw-r--r-- | delphi/Awkward/utils/wrapper.pas | 450 |
15 files changed, 8491 insertions, 0 deletions
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 a<b then
+ result:=b
+ else
+ result:=a;
+end;
+
+function mGetMem(var dst;size:integer):pointer;
+begin
+{$IFDEF USE_MMI}
+ if @mmi.malloc<>nil 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 pos<i then
+ begin
+ if (pos+len)>i 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 pos<i then
+ begin
+ if (pos+len)>i 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 result<src then
+ result:=nil;
+ end
+ else
+ result:=nil;
+end;
+
+function StrScanW(src:PWideChar;c:WideChar):PWideChar;
+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 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 result<src then
+ result:=nil;
+ end
+ else
+ result:=nil;
+end;
+
+function StrLen(Str: PAnsiChar): Cardinal;
+var
+ P : PAnsiChar;
+begin
+ P := Str;
+ if P<>nil 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<len do
+ begin
+ if (stime[i]<'0') or (stime[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 i<NumRecs do
+ begin
+ if (p^.flags and hkAssigned)<>0 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 i<NumRecs do
+ begin
+ if (p^.flags and hkAssigned)=0 then
+ break;
+ inc(p);
+ inc(i);
+ end;
+ end;
+ if i=NumRecs then // allocate if not found
+ begin
+ if NumRecs=MaxRecs then
+ begin
+ inc(MaxRecs,PageStep);
+ GetMem (tmp ,MaxRecs*SizeOf(THKRec));
+ FillChar(tmp^,MaxRecs*SizeOf(THKRec),0);
+ move(HKRecs^,tmp^,NumRecs*SizeOf(THKRec));
+ FreeMem(HKRecs);
+ HKRecs:=tmp;
+ end;
+ inc(NumRecs);
+ end;
+ if global then
+ HKRecs^[i].flags:=hkAssigned or hkGlobal
+ else
+ HKRecs^[i].flags:=hkAssigned;
+ HKRecs^[i].hotkey:=HotKeyDlgToHook(ahotkey);
+ result:=i;
+end;
+
+function AddProc(aproc:AWKHotKeyProc;ahotkey:integer;global:bool=false):integer;
+begin
+ result:=1;
+ if @aproc=nil then exit;
+
+ with HKRecs^[CheckTable(ahotkey,global)] do
+ begin
+ proc :=aproc;
+ handle:=0;
+ if global then
+ begin
+ atom:=GetAtom(hotkey);
+ if not RegisterHotKey(hiddenwindow,atom,hi(hotkey),lo(hotkey)) then
+ result:=0;
+ end;
+ end;
+end;
+
+// search needed
+function AddProcWin(ahotkey:integer;wnd:HWND):integer;
+begin
+ result:=CheckTable(ahotkey,false);
+ with HKRecs^[result] do
+ begin
+ handle:=wnd;
+ end;
+end;
+
+function AddProc(ahotkey:integer;wnd:HWND;aproc:AWKHotKeyProc):integer;
+begin
+ if @aproc=nil then
+ begin
+ result:=0;
+ exit;
+ end;
+
+ result:=AddProcWin(ahotkey,wnd);
+ if result<0 then
+ result:=0
+ else
+ begin
+ HKRecs^[result].proc:=@aproc;
+ end;
+end;
+
+function AddProc(ahotkey:integer;wnd:HWND;msg:DWORD):integer;
+begin
+ result:=AddProcWin(ahotkey,wnd);
+ if result<0 then
+ result:=0
+ else
+ begin
+ HKRecs^[result].flags:=HKRecs^[result].flags or hkMessage;
+ HKRecs^[result].proc :=pointer(msg);
+ end;
+end;
+
+function DelProc(hotkey:integer):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) 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 i<cnt do
+ begin
+ gci.iItem:=i;
+ gci.Flags:=GCI_BYINDEX+GCI_HCONTACT+GCI_ID;
+ CallService(MS_GC_GETINFO,0,dword(@gci));
+ if gci.hContact=hContact then
+ begin
+ SendChatText(gci.pszID.w,pszModule,pszText);
+ break;
+ end;
+ inc(i);
+ end;
+end;
+
+function FindContactHandle(proto:pAnsiChar;const dbv:TDBVARIANT;is_chat:boolean=false):THANDLE;
+var
+ uid:pAnsiChar;
+ ldbv:TDBVARIANT;
+ hContact:THANDLE;
+ pw:pWideChar;
+begin
+ result:=0;
+ if not is_chat then
+ begin
+ uid:=pAnsiChar(CallProtoService(proto,PS_GETCAPS,PFLAG_UNIQUEIDSETTING,0));
+ if dword(uid)=CALLSERVICE_NOTFOUND then exit;
+ end;
+
+ hContact:=CallService(MS_DB_CONTACT_FINDFIRST,0,0);
+ while hContact<>0 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('<Root Group>'));
+ 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 j<oldcnt do
+ begin
+ FreeMem(hold[j]);
+ inc(j);
+ end;
+//copy new to old
+ move(har,hold,SizeOf(har));
+ oldcnt:=harcnt;
+// move active to begin
+ if idx<>0 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 i<harcnt do
+ begin
+ flg:=false;
+ j:=0;
+ while j<oldcnt do
+ begin
+ if StrCmpW(har[i],hold[j])=0 then
+ begin
+ flg:=true; //old=new
+ break;
+ end;
+ inc(j);
+ end;
+ if not flg then // new!!
+ begin
+ ArSwitch(i);
+ exit;
+ end;
+ inc(i);
+ end;
+ end
+ else
+ begin
+ while i<oldcnt do
+ begin
+ j:=0;
+ while j<harcnt do
+ begin
+ if StrCmpW(hold[i],har[j])=0 then
+ begin
+ ArSwitch(j);
+ exit;
+ end;
+ inc(j);
+ end;
+ inc(i);
+ end;
+ end;
+ ArSwitch(0);
+ result:=-1;
+end;
+
+const
+ MaxHandle = 8192;
+
+type
+ prec = ^trec;
+ trec = record
+ handle:thandle;
+ fname:pWideChar;
+ end;
+
+const
+ BufSize = $1000;
+var
+ TmpBuf:array [0..BufSize-1] of WideChar;
+
+function GetName(param:pdword):dword; //stdcall;
+begin
+ result:=0;
+ if NTQueryObject(prec(param)^.handle,ObjectNameInformation,
+ @TmpBuf,BufSize*SizeOf(WideChar),pdword(nil)^)=0 then
+ begin
+ GetMem(prec(param)^.fname,(lstrlenw(TmpBuf)-3)*SizeOf(WideChar));
+ StrCopyW(prec(param)^.fname,TmpBuf+4);
+ end;
+end;
+
+function TestHandle(Handle:THANDLE;MultiThread:bool):pWideChar;
+var
+ hThread:THANDLE;
+ rec:trec;
+begin
+ result:=nil;
+
+ if (NTQueryObject(Handle,ObjectTypeInformation,
+ @TmpBuf,BufSize*SizeOf(WideChar),pdword(nil)^)<>0) 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 (harcnt<maxhandles) then
+ begin
+ har[harcnt]:=pc;
+ inc(harcnt);
+ end
+ else
+ FreeMem(pc);
+ end;
+ end;
+ CloseHandle(h);
+ end
+ else
+ begin
+ inc(handles,4); //skip empty number and non-duplicates
+ if Handles>MaxHandle 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 <rect.left then rc.left :=rect.left;
+ if rc.top <rect.top then rc.top :=rect.top;
+end;
+
+function GetDlgText(wnd:HWND;getAnsi:boolean=false):pointer;
+var
+ a:cardinal;
+begin
+ result:=nil;
+ if getAnsi then
+ begin
+ a:=SendMessageA(wnd,WM_GETTEXTLENGTH,0,0)+1;
+ if a>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<cnt) then
+ result:=result or 2;
+end;
+
+//----- Combobox functions -----
+
+function CB_SelectData(cb:HWND;data:dword):integer; overload;
+var
+ i:integer;
+begin
+ result:=0;
+ for i:=0 to SendMessage(cb,CB_GETCOUNT,0,0)-1 do
+ begin
+ if data=dword(SendMessage(cb,CB_GETITEMDATA,i,0)) then
+ begin
+ result:=i;
+ break;
+ end;
+ end;
+ result:=SendMessage(cb,CB_SETCURSEL,result,0);
+end;
+
+function CB_SelectData(Dialog:HWND;id:cardinal;data:dword):integer; overload;
+begin
+ result:=CB_SelectData(GetDlgItem(Dialog,id),data);
+end;
+
+function CB_GetData(cb:HWND;idx:integer=-1):dword;
+begin
+ if idx<0 then
+ idx:=SendMessage(cb,CB_GETCURSEL,0,0);
+ result:=SendMessage(cb,CB_GETITEMDATA,idx,0);
+end;
+
+function CB_AddStrData(cb:HWND;astr:pAnsiChar;data:integer=0;idx:integer=-1):HWND;
+begin
+ result:=cb;
+ if idx<0 then
+ idx:=SendMessage(cb,CB_ADDSTRING,0,dword(astr))
+ else
+ idx:=SendMessage(cb,CB_INSERTSTRING,idx,dword(astr));
+ SendMessage(cb,CB_SETITEMDATA,idx,data);
+end;
+
+function CB_AddStrDataW(cb:HWND;astr:pWideChar;data:integer=0;idx:integer=-1):HWND;
+begin
+ result:=cb;
+ if idx<0 then
+ idx:=SendMessageW(cb,CB_ADDSTRING,0,dword(astr))
+ else
+ idx:=SendMessageW(cb,CB_INSERTSTRING,idx,dword(astr));
+ SendMessage(cb,CB_SETITEMDATA,idx,data);
+end;
+
+end.
|