{*************************************************************************}
{                                                                         }
{ MicroUtils.pas - some functions' analogues from some enourmous units    }
{                                                                         }
{ This file is a part of the project:                                     }
{   Micro Tools - modules to keep size of applications small              }
{                                                                         }
{ © Parfenov Alexey Andreevich, 2007                                      }
{                                                                         }
{ e-mail: AlkatrazStudio@yandex.ru                                        }
{                                                                         }
{ This library is free software; you can redistribute it and/or           }
{ modify it under the terms of the GNU General Public License             }
{ as published by the Free Software Foundation; either version 2.1 of     }
{ the License, or (at your option) any later version.                     }
{                                                                         }
{ This library is distributed in the hope that it will be useful,         }
{ but WITHOUT ANY WARRANTY; without even the implied warranty of          }
{ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        }
{ General Public License for more details.                                }
{                                                                         }
{ You may read GNU General Public License at:                             }
{   http://www.gnu.org/copyleft/gpl.html                                  }
{                                                                         }
{ last modified: 25.04.2009                                               }
{*************************************************************************}
unit MicroUtils;
                         
interface

uses windows,messages;

function ReadParamStr:String;
function LastDelimiter(s:string):word;
function ExtractFileDir(s:string):string;
function ExtractFileName(s:string):string;
function ExtractFileExt(s:string):string;
function ExtractFileNameOnly(s:string):string;
function FileExist(FileName:String;DoDirectory:boolean=false):boolean;
procedure Sleep(Milliseconds:Cardinal);
procedure ShowBalloonTip(Handle:HWND;Rect:TRect; Icon: integer; Title: pchar; Text: PWideChar);
function Rus(mes: string): string;
function GetProgDir:string;
function UpperCase(s:string):string;
function IntToStr(Value: Integer): string;
function StrToInt(const S: string): Integer;
function StrCopy(Dest: PChar; const Source: PChar): PChar;
function Sgn(X:Real):ShortInt;
function angl(y,x:extended):extended;  assembler;
function GetSystemDir: String;
function GetWindowsDir : string;
function GetWorkDir : string;
function GetFullPath(s:string):string;
function AnsiStrIComp(s1,s2:string):integer;
procedure ProcessMessages;
procedure FreeAndNil(var obj);

implementation

function ReadParamStr:String;
var
  a:word;
begin
  result:='';
  if ParamCount=0 then exit;
  for a:=1 to ParamCount do result:=result+ParamStr(a)+' ';
  Setlength(result,length(result)-1);
end;

function LastDelimiter(s:string):word;
begin
  result:=length(s);
  while(result>0)and(s[result]<>'\')do dec(result);
end;

function ExtractFileDir(s:string):string;
begin
  result:=copy(s,1,LastDelimiter(s)-1);
end;

function ExtractFileName(s:string):string;
var
  n:word;
begin
  if s='' then begin result:='';exit;end;
  n:=LastDelimiter(s);
  result:=copy(s,n+1,length(s)-n);
end;

function ExtractFileExt(s:string):string;
var
  ss:string;
  a,n:word;
begin
  if s='' then begin result:='';exit;end;
  ss:=ExtractFileName(s);n:=length(ss);
  a:=n;
  while(ss[a]<>'.')and(a>=1)do dec(a);
  if a=0 then result:='' else result:=copy(ss,a,n-a+1);
end;

function ExtractFileNameOnly(s:string):string;
var
  ss:string;
  a,n:word;
begin
  if s='' then begin result:='';exit;end;
  ss:=ExtractFileName(s);n:=length(ss);
  a:=n;
  while(ss[a]<>'.')and(a>=1)do dec(a);
  if a=0 then result:=ss else result:=copy(ss,1,a-1);
end;

function FileExist(FileName:String;DoDirectory:boolean=false):boolean;
var
  h:THandle;
  info:_BY_HANDLE_FILE_INFORMATION;
  isFile:boolean;
begin
  h:=CreateFile(PAnsiChar(FileName),0,
  FILE_SHARE_READ,Nil,OPEN_EXISTING,
  FILE_FLAG_BACKUP_SEMANTICS,0);
  result:=(h<>INVALID_HANDLE_VALUE);
  if not result then begin closehandle(h);exit;end;
  result:=GetFileInformationByHandle(h,info);
  if not result then begin closehandle(h);exit;end;
  isFile:=((info.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)=0);
  result:=(DoDirectory=(not isFile));
  CloseHandle(h);
end;

procedure Sleep(Milliseconds:Cardinal);
var
  h:Cardinal;
begin
  h:=CreateEvent(nil,true,false,'');
  WaitForSingleObject(h,Milliseconds);
  CloseHandle(h);
end;

procedure ShowBalloonTip(Handle:HWND; Rect:TRect; Icon: integer; Title: pchar; Text: PWideChar);
const
  TOOLTIPS_CLASS = 'tooltips_class32';
  TTS_ALWAYSTIP = $01;
  TTS_NOPREFIX = $02;
  TTS_BALLOON = $40;
  TTF_SUBCLASS = $0010;
  TTF_TRANSPARENT = $0100;
  TTF_CENTERTIP = $0002;
  TTM_ADDTOOL = $0400 + 50;
  TTM_SETTITLE = (WM_USER + 32);
  ICC_WIN95_CLASSES = $000000FF;
type
  TOOLINFO = packed record
    cbSize: Integer;
    uFlags: Integer;
    hwnd: THandle;
    uId: Integer;
    rect: TRect;
    hinst: THandle;
    lpszText: PWideChar;
    lParam: Integer;
  end;
var
  hWndTip: THandle;
  ti: TOOLINFO;
  hWnd: THandle;
begin
  hWnd := Handle;
  hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,
    WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
    0, 0, 0, 0, hWnd, 0, HInstance, nil);
  if hWndTip <> 0 then
  begin
    SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0,
      SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
    ti.cbSize := SizeOf(ti);
    ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
    ti.hwnd := hWnd;
    ti.lpszText := Text;
    Windows.GetClientRect(hWnd, ti.rect);
    ti.rect.Left:=ti.rect.Left+rect.Left;
    ti.rect.Top:=ti.rect.Top+rect.Top;
    ti.rect.Right:=ti.rect.left+(rect.Right-rect.Left);
    ti.rect.Bottom:=ti.rect.top+(rect.Bottom-rect.Top);
    SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti));
    SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title));
  end;
end;

function Rus(mes: string): string;
var
  i: integer;
begin
  for i := 1 to length(mes) do
    case mes[i] of
      #192..#239: mes[i] := Chr(Ord(mes[i]) - 64);
      #240..#255: mes[i] := Chr(Ord(mes[i]) - 16);
      #184:;// yo - not supported as well as YO... why???
      #168:;// ...so OEM charset mustdie then!
    end;
  rus := mes;
end;

function GetProgDir:string;
begin
  result:=ExtractFileDir(ParamStr(0));
end;

function UpperCase(s:string):string;
var
  a,n:integer;
  c:char;
begin
  n:=length(s);result:='';
  if n>0 then
    for a:=1 to n do
    begin
      c:=s[a];
      if((c>='a')and(c<='z'))or((c>='à')and(c<='ÿ'))then
        result:=result+chr(ord(c)-32)
      else
        if c='¸' then
          result:=result+chr(ord(c)-16)
        else
          result:=result+c;
    end;
end;

function StrCopy(Dest: PChar; const Source: PChar): PChar;
asm
        PUSH    EDI
        PUSH    ESI
        MOV     ESI,EAX
        MOV     EDI,EDX
        MOV     ECX,0FFFFFFFFH
        XOR     AL,AL
        REPNE   SCASB
        NOT     ECX
        MOV     EDI,ESI
        MOV     ESI,EDX
        MOV     EDX,ECX
        MOV     EAX,EDI
        SHR     ECX,2
        REP     MOVSD
        MOV     ECX,EDX
        AND     ECX,3
        REP     MOVSB
        POP     ESI
        POP     EDI
end;

procedure CvtInt;
asm
        OR      CL,CL
        JNZ     @CvtLoop
@C1:    OR      EAX,EAX
        JNS     @C2
        NEG     EAX
        CALL    @C2
        MOV     AL,'-'
        INC     ECX
        DEC     ESI
        MOV     [ESI],AL
        RET
@C2:    MOV     ECX,10

@CvtLoop:
        PUSH    EDX
        PUSH    ESI
@D1:    XOR     EDX,EDX
        DIV     ECX
        DEC     ESI
        ADD     DL,'0'
        CMP     DL,'0'+10
        JB      @D2
        ADD     DL,('A'-'0')-10
@D2:    MOV     [ESI],DL
        OR      EAX,EAX
        JNE     @D1
        POP     ECX
        POP     EDX
        SUB     ECX,ESI
        SUB     EDX,ECX
        JBE     @D5
        ADD     ECX,EDX
        MOV     AL,'0'
        SUB     ESI,EDX
        JMP     @z
@zloop: MOV     [ESI+EDX],AL
@z:     DEC     EDX
        JNZ     @zloop
        MOV     [ESI],AL
@D5:
end;

function IntToStr(Value: Integer): string;
asm
        PUSH    ESI
        MOV     ESI, ESP
        SUB     ESP, 16
        XOR     ECX, ECX
        PUSH    EDX
        XOR     EDX, EDX
        CALL    CvtInt
        MOV     EDX, ESI
        POP     EAX
        CALL    System.@LStrFromPCharLen
        ADD     ESP, 16
        POP     ESI
end;

function Sgn(X:Real):ShortInt;
begin
  if X>0 then result:=1
  else
  if X<0 then result:=-1
  else
  result:=0;
end;

function angl(y,x:extended):extended;  assembler;
 asm  
  fld y
  fld x  
  fpatan  
 end;

function GetSystemDir: String;
var Buf: array[ 0..MAX_PATH ] of Char;
begin
  GetSystemDirectory( @ Buf[ 0 ], MAX_PATH + 1 );
  Result := PChar( @ Buf[ 0 ] ) ;
end;

function GetWindowsDir : string;
var Buf : array[ 0..MAX_PATH ] of Char;
begin
  GetWindowsDirectory( @Buf[ 0 ], MAX_PATH + 1 );
  Result := PChar( @ Buf[ 0 ] );
end;

function GetWorkDir : string;
var Buf: array[ 0..MAX_PATH ] of Char;
begin
  GetCurrentDirectory( MAX_PATH + 1, @ Buf[ 0 ] );
  Result := PChar( @ Buf[ 0 ] ) ;
end;

function GetFullPath(s:string):string;
var
  ss:array[0..MAX_PATH]of Char;
  p:Pchar;
begin
  if SearchPath(nil, PChar(s), nil, MAX_PATH, ss, P) > 0 then
    result:=ss else result:='';
end;

function AnsiStrIComp(s1,s2:string):integer;
var
  a1,a2:string;
begin
  a1:=string(UpperCase(PAnsiChar(s1)));
  a2:=string(UpperCase(PAnsiChar(s2)));
  if a1>a2 then result:=1 else if a1<a2 then result:=-1 else result:=0;
end;

procedure ProcessMessages;
var
  m:TMsg;
begin
  while PeekMessage(m,0,0,0,PM_REMOVE) do
  begin
    if m.Message=WM_QUIT then exit;
    TranslateMessage(m);
    DispatchMessage(m);
  end;
end;

procedure FreeAndNil(var obj);
begin
  if TObject(obj)<>nil then
  begin
    TObject(obj).Free;
    TObject(obj):=nil;
  end;
end;

function StrToInt(const S: string): Integer;
var
  E: Integer;
begin
  Val(S, Result, E);
end;

end.
