unit wutils;
{Statische Bibliothek für Windows-typische Problemchen}
{$C MOVEABLE PRELOAD PERMANENT} {gleiche Attribute wie Unit SYSTEM}
{Die Einbindung dieser Unit verbraucht 10 Datenbytes}
interface
uses WinProcs,WinTypes,ShellAPI;
{MessageBox-Funktionen auf Basis von unterteilten Ressourcen-Strings}
const
StdMBoxTitle: PChar = nil;
StdMBoxStyle: Word = MB_OK or MB_IconExclamation;
StdProfile: PChar = nil; {Vorgabe: WIN.INI}
MB_Sound = $0080;
HKCR=HKEY_Classes_Root;
WF_WinNT=$4000; {zusätzlich für GetWinFlags()}
function MBox(WndParent:HWnd; ID:Word; var p):Integer;
function MBox1(WndParent:HWnd; ID:Word; S:PChar):Integer;
procedure StrDisposeNoDS(var SP: PChar);
function lStrChr(Str:PChar; C:Char):PChar;
function GetPrfXX(Section,Key:PChar; var P; Size:Word):Boolean;
function SetPrfXX(Section,Key:PChar; const P; T:PChar):Boolean;
function GetWndXX(Wnd:HWnd; var P; Size:Word):Boolean;
function GetDlgItemXX(Wnd:HWnd; ID:Word; var P; Size:Word):Boolean;
function GetModuleDescription(FName,Descript:PChar):Boolean;
{extrahiert aus Windows-EXE Modulbeschreibung, max. 255 Zeichen, ANSI-Font
FName kann auch ein Dateihandle einer offenen Datei sein}
procedure memmove(d,s:Pointer; l:Word); {prüft auf Überlappung, rep movsb}
const
GX_PChar =$0000;
GX_Int =$FFF9;
GX_Word =$FFF8;
GX_Long =$FFFB;
OFN_LongNames =$200000;
{Hinzufügen oder Entfernen von VxD's zur/aus SYSTEM.INI}
const
ARV_CantRemove = 1;
ARV_CantAdd = 2;
ARV_FailCreateTempFile = -2;
ARV_FailOpenSystemIni = -3;
ARV_FailReadWrite = -4;
ARV_FailDelete = -5;
ARV_FailRename = -6;
function AddRemoveVxD(AddPath,RemovVxD:PChar):Integer;
{AddPath bezeichnet ein neues VxD samt Pfad; NIL wenn kein neues}
{RemovVxD bezeichnet ein zu entfernendes VxD (kein Pfad erforderlich)}
{Registrierungs-Hilfen}
function RegSetRoot(Path,Value:PChar):Boolean;
function RegGetRoot(Path,Value:PChar; VL:Word):Boolean;
function RegSetVal(Key:HKey;Path,Value:PChar):Boolean;
function RegGetVal(Key:HKey;Path,Value:PChar; VL:Word):Boolean;
function WriteProfileInt(Section,Key:PChar; Value:Integer):Bool;
{C-mäßige String-Umwandlung in darstellbares Format}
function EscapeStr(src:PChar; slen:Word; dst:PChar; dlen:Word):Word;
function UnescapeStr(src, dst:PChar; dlen:Word):Word;
{Dateifunktionen}
procedure AnsiDosFunc;
function _ldelete(S: PChar):Integer;
procedure ShortYield;
function GetFileNamePtr(S:PChar):PChar;
{liefert Zeiger hinter das letzte Auftreten von /\: oder Stringanfang}
function GetFileNameExt(S:PChar):PChar;
{liefert Zeiger AUF DEN PUNKT oder AUF DIE NULL, niemals NIL}
function RemoveTrailSlash(S:PChar):PChar;
{liefert Zeiger AUF DIE NULL, entfernt ggf. mehr als 1 Slash}
procedure TransparentBlt(DC:HDC; x,y:Integer; HBM:HBitmap; cr:TColorRef);
{Kopiert Bitmap und wandelt dabei die Transparent-Farbe der Bitmap in den
Hintergrund-Pinsel des Zielgerätekontexts (keine echte Transparenz!)}
function CopyFile(NameS,NameD:PChar; Overwrite: Bool):Bool;
{Funktionskompatibel zur Win32-API, unterstützt lange Dateinamen}
procedure CenterDlg(Wnd:HWnd);
{Zentriert Wnd im Elternfenster oder Desktopfenster}
const
Drive_CDROM =5;
Drive_RAM =6;
function GetDriveTypeEx(Drv:Integer):Word;
type HFile=Integer; {fehlt bei BP7}
const HFile_Error=-1; {fehlt bei BP7}
type
LongRec=record
Lo,Hi:Word;
end;
LongRecI=record
Lo,Hi:Integer;
end;
PtrRec=record
Ofs,Sel:Word;
end;
WordRec=record
Lo,Hi:Byte;
end;
TS255=array[0..255] of Char;
TS127=array[0..127] of Char;
TS63=array[0..63] of Char;
TS31=array[0..31] of Char;
TS15=array[0..15] of Char;
TS7=array[0..7] of Char;
PDropFileStruct=^TDropFileStruct;
TDropFileStruct=record
wSize: Word;
MPos: TPoint;
InNcArea: Bool;
FNames: array[0..1] of Char;
end;
function GetDragClientFromPos(const P:TPoint):HWnd;
function PerformDrop(ToWnd:HWnd;argc:Integer;const argv:PChar):Bool;
{Arbeit mit "Huge"-Zeigern auf Speicher mit mehr als 64 KB}
procedure IncHP(var P:PChar; By: Word);
procedure DecHP(var P:PChar; By: Word);
procedure IncHPL(var P:PChar; By: LongInt);
{Minimum und Maximum, vzb. und vzl.}
function min(I1,I2:Integer):Integer;
inline($58/$5A/$39/$D0/$7C/$01/$92);
{pop ax; pop dx; cmp ax,dx; jl $+3; xchg dx,ax}
function minW(W1,W2:Word):Word;
inline($58/$5A/$39/$D0/$72/$01/$92);
{pop ax; pop dx; cmp ax,dx; jb $+3; xchg dx,ax}
function max(I1,I2:Integer):Integer;
inline($58/$5A/$39/$D0/$7F/$01/$92);
{pop ax; pop dx; cmp ax,dx; jg $+3; xchg dx,ax}
function maxW(W1,W2:Word):Word;
inline($58/$5A/$39/$D0/$77/$01/$92);
{pop ax; pop dx; cmp ax,dx; ja $+3; xchg dx,ax}
function Parity(W:Word):Boolean;
inline($58/$09/$C0/$B0/$00/$7B/$02/$B0/$01);
{pop ax; or ax,ax; mov al,0; jpo $+4; mov al,1}
function LongMul(A,B:Integer):LongInt;
inline($5A/$58/$F7/$EA);
{pop dx; pop ax; imul dx}
function LongMulW(A,B:Word):LongInt;
inline($5A/$58/$F7/$E2);
{pop dx; pop ax; mul dx}
function LongDiv(A:LongInt;B:Integer):Integer;
inline($5B/$58/$5A/$F7/$FB);
{pop bx; pop ax; pop dx; idiv bx - rundet nicht}
function LongDivR(A:LongInt;B:Integer):LongInt;
inline($5B/$58/$5A/$F7/$FB);
{pop bx; pop ax; pop dx; idiv bx - mit Restrückgabe im High-Teil}
function LongDivW(A:LongInt;B:Word):Word;
inline($5B/$58/$5A/$F7/$F3);
{pop bx; pop ax; pop dx; div bx - rundet nicht}
function lLongDivW(A:LongInt;B:Word):Word;
inline($5B/$58/$5A/$39/$DA/$72/$05/$B8/$FF/$FF/$EB/$02/$F7/$F3);
{pop bx; pop ax; pop dx; cmp dx,bx; jc $+7; mov ax,-1; jmp $+4;
div bx - mit Begrenzung auf 65535}
function LongDivWR(A:LongInt;B:Word):LongInt;
inline($5B/$58/$5A/$F7/$F3);
{pop bx; pop ax; pop dx; div bx - mit Restrückgabe im High-Teil}
function MulDivW(A,B,C:Word):Word;
inline($5B/$58/$5A/$F7/$E2/$F7/$F3);
{pop bx; pop ax; pop dx; mul dx; div bx - rundet nicht}
function idiv2(x: Integer):Integer;
{weil Turbo's shr nicht arithmetisch schiebt!}
inline($58/$D1/$F8); {pop ax; sar ax,1}
function Bool2MenuCheck(Check:Bool):Word;
{konvertiert Bool-Argument in MF_UnChecked(false) oder MF_Checked(true)}
inline($5A/$09/$C0/$74/$03/$B8/>MF_Checked);
{Das schöne am Stack-Speicher ist, man muß ihn nicht freigeben!}
function StackAlloc(size:Word):Pointer;
{reserviert dynamisch Stack-Speicher (size sollte gerade sein)}
inline($58/$C429/$E089/$D28C); {pop ax; sub sp,ax; mov ax,sp; mov dx,ss}
procedure StackFree(size:Word);
{gibt o.g. StackAlloc-Speicher frei (size muß gleich sein!)}
inline($58/$C401); {pop ax; add sp,ax}
function StackAlloc2(size:Word):Pointer;
{reserviert dynamisch Stack-Speicher (size wird gerade gemacht)}
inline($58/$40/$FE24/$C429/$E089/$D28C);
{pop ax; inc ax; and al,0FEh; sub sp,ax; mov ax,sp; mov dx,ss}
procedure StackFree2(size:Word);
{gibt o.g. StackAlloc2-Speicher frei (size muß gleich sein!)}
inline($58/$40/$FE24/$C401); {pop ax; inc ax; and al,0FEh; add sp,ax}
type
Bool2MenuGray=Word; {Hier: Einfache Typkonvertierung}
{konvertiert Bool-Argument in MF_Enabled(false!) oder MF_Grayed(true!)}
procedure SortRect(var R:TRect);
{sortiert die Koordinaten in R so um,
daß top/left links oben und bottom/right rechts unten ist}
function FirstWord(var S:PChar;Delim:Word):PChar;
{Abspalten des ersten Wortes von Zeichenkette SP
LoByte(Delim) enthält Trennzeichen, HighByte div. Flags}
const
FW_TrimLeft =$0100;
FW_TrimRight =$0200;
FW_DblQuote =$0400;
FW_SglQuote =$0800;
FW_CRLFisWS =$4000;
FW_NeverNIL =$8000;
FW_CmdLine =Ord(' ') or FW_TrimLeft or FW_DblQuote;
FW_Path =Ord(';') or FW_DblQuote;
{Nützliche Funktionen der Windows-API}
procedure __AHShift;
procedure __AHIncr;
procedure __0000H;
procedure __0040H;
procedure __A000H;
procedure __B000H;
procedure __B800H;
procedure __C000H;
procedure __D000H;
procedure __E000H;
procedure __F000H;
procedure __RomBios;
procedure __WinFlags;
function _hread(f:HFile;Buf:PChar;BufLen:LongInt):LongInt;
function _hwrite(f:HFile;Buf:PChar;BufLen:LongInt):LongInt;
function _LocalLock(Mem: THandle): Word;
function LocalLock(Mem: THandle): Pointer; {wegen Segmentdefinition!}
function SendMessageWW(Wnd: HWnd; Msg, wParam, lParHi, lParLo: Word): LongInt;
function SendMessageP(Wnd: HWnd; Msg, wParam: Word; lParam: Pointer): LongInt;
function SendDlgItemMsgWW(Dlg: HWnd; IDDlgItem: Integer; Msg, wParam,
lParHi, lParLo: Word): LongInt;
function SendDlgItemMsgP(Dlg: HWnd; IDDlgItem: Integer; Msg, wParam: Word;
lParam: Pointer): LongInt;
{Korrekturen fehlerhaft definierter API-Funktionen}
procedure CopyRect(var DestRect: TRect; const SourceRect: TRect);
function CreatePolygonRgn(const Points; Count, PolyFillMode: Integer): HRgn;
function CreatePolyPolygonRgn(const Points; const PolyCounts; Count,
PolyFillMode: Integer): HRgn;
function CreateRectRgnIndirect(const Rect: TRect): HRgn;
function EqualRect(const Rect1, Rect2: TRect): Bool;
function FillRect(DC: HDC; const Rect: TRect; Brush: HBrush): Integer;
procedure FrameRect(DC: HDC; const Rect: TRect; Brush: HBrush);
function IntersectRect(var DestRect: TRect; const Src1Rect, Src2Rect: TRect): Integer;
procedure InvertRect(DC: HDC; const Rect: TRect);
function IsRectEmpty(const Rect: TRect): Bool;
function Polygon(DC: HDC; const Points; Count: Integer): Bool;
function Polyline(DC: HDC; const Points; Count: Integer): Bool;
function PolyPolygon(DC: HDC; const Points; const PolyCounts;
Count: Integer): Bool;
function PtInRect(const Rect: TRect; Point: TPoint): Bool;
function RectInRegion(Rgn: HRgn; const Rect: TRect): Bool;
function RectVisible(DC: HDC; const Rect: TRect): Bool;
function RegisterClass(const WndClass: TWndClass): Bool;
function ScrollDC(DC: HDC; dx, dy: Integer; const Scroll, Clip: TRect;
UpdateRgn: HRgn; UpdateRect: PRect): Bool;
function SetDIBits(DC: HDC; Bitmap: THandle; StartScan, NumScans: Word;
Bits: Pointer; const BitsInfo: TBitmapInfo; Usage: Word): Integer;
function SetDIBitsToDevice(DC: HDC; DestX, DestY, Width, Height, SrcX, SrcY,
nStartScan, NumScans: Word; Bits: Pointer; const BitsInfo: TBitmapInfo;
Usage: Word): Integer;
procedure SetSysColors(Changes: Integer; const SysColor; const ColorValues);
function StretchDIBits(DC: HDC; DestX, DestY, DestWidth, DestHegiht, SrcX,
SrcY, SrcWidth, SrcHeight: Word; Bits: Pointer; const BitsInfo: TBitmapInfo;
Usage: Word; Rop: LongInt): Integer;
function TabbedTextOut(HC: HDC; X, Y: Integer; Str: PChar; Count: Integer;
TabPositions: Integer; const TabStopPositions; TabOrigin: Integer): LongInt;
procedure Throw(const CatchBuf: TCatchBuf; ThrowBack: Integer);
function UnionRect(var DestRect: TRect; const Src1Rect, Src2Rect: TRect):
Integer;
function wvsprintf(DestStr, Format: PChar; const ArgList): Integer;
function wsprintf: Integer; {Nur für Assembler}
function waveInClose(hWaveIn: Word): Word; {Bösartiger Bug!!}
{Umdefinition des Rückgabewertes}
function GetProfileInt(Sec,Key:PChar; Def: Integer): Integer;
function GetPrivateProfileInt(Sec,Key:PChar; Def: Integer; FileName: PChar):
Integer;
function MMTaskCreate(Proc:TFarProc; var Task: THandle; Data:LongInt):Integer;
{liefert womöglich Fehlercode, 0 wenn OK}
function MMTaskBlock(h:THandle): Word;
function MMTaskSignal(h:THandle): Bool;
function MMGetCurrentTask: THandle;
procedure MMTaskYield;
implementation
uses Strings,Win31;
function MBox(WndParent:HWnd; ID:Word; var p):Integer;
{** NICHT OK für DLL **}
var
S,S2: array[0..255]of Char; {2 Puffer; leider so erforderlich}
SPT,SPH: PChar; {Zeiger auf Text und Titel}
I,K: Integer;
TextType:Word;
begin
TextType:=StdMBoxStyle;
I:=LoadString(HInstance,ID,S,sizeof(S)); {I=Anzahl der Zeichen insgesamt}
SPT:=S;
if S[0]='$' then begin
Val(S,TextType,K);
SPT:=S+lStrLen(S)+1;
end;
SPH:=SPT+lStrLen(SPT)+1;
if SPH-S>I then SPH:=StdMBoxTitle;
wvsprintf(S2,SPT,P);
if TextType and MB_Sound <>0 then MessageBeep(TextType and $0070);
MBox:=MessageBox(WndParent,S2,SPH,TextType and not MB_Sound);
end;
function MBox1(WndParent:HWnd; ID:Word; S:PChar):Integer;
{** NICHT OK für DLL **}
begin
MBox1:=MBox(WndParent,ID,S);
end;
function AddRemoveVxD(AddPath,RemovVxD:PChar):Integer;
{** OK für DLL **}
const
devkey: array[0..7]of Char='device=';
var
f1,f2: Text; {zum SYSTEM.INI parsen}
S,Line: array[0..255]of Char;
PS,PL: PChar;
InsideSection,CopyLine: Boolean;
W: Word;
begin
WritePrivateProfileString(nil,nil,nil,'SYSTEM.INI'); {Cache leeren}
W:=GetWindowsDirectory(S,sizeof(S));
if S[W-1]<>'\' then begin S[W]:='\'; S[W+1]:=#0; end; {Backslash anhängen}
PS:=S+lStrLen(S); {auf die Null}
lStrCpy(PS,'SYSTEM.IN$'); {Tempname anhängen}
Assign(f2,S); ReWrite(f2); {zum Schreiben öffnen}
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailCreateTempFile;
exit;
end;
lStrCpy(PS,'SYSTEM.INI'); {Richtigen Namen anhängen}
Assign(f1,S); Reset(f1); {zum Lesen öffnen}
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailOpenSystemIni;
exit;
end;
InsideSection:=false;
while not eof(f1) do begin
ReadLn(f1,Line); CopyLine:=true;
if Line[0]='[' then begin
InsideSection:=(StrLIComp(Line,'[386Enh]',8)=0);
if InsideSection and (AddPath<>nil) then begin
WriteLn(f2,Line); {Sektionsbeginn beibehalten}
WriteLn(f2,devkey,AddPath); {Neue Zeile hinzufügen}
AddPath:=nil; {Einmal hinzufügen genügt}
CopyLine:=false; {nichts weiter...}
end;
end else begin
if InsideSection
and (RemovVxD<>nil)
and (StrLIComp(Line,devkey,7)=0)
and (lStrCmpi(GetFileNamePtr(Line+7),RemovVxD)=0) then begin
CopyLine:=false;
RemovVxD:=nil; {erledigt}
end;
end;
if CopyLine then WriteLn(f2,Line);
end;
Close(f1); Close(f2);
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailReadWrite;
exit; {Problem! Quelle nicht löschen!}
end;
Erase(f1); {Quelle löschen}
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailDelete;
exit;
end;
ReName(f2,S); {Ziel umbenennen}
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailRename;
exit;
end;
AddRemoveVxD:=0;
if RemovVxD<>nil then AddRemoveVxD:=ARV_CantRemove;
if AddPath<>nil then AddRemoveVxD:=ARV_CantAdd;
end;
function RegSetRoot(Path,Value:PChar):Boolean;
begin {** OK für DLL **}
RegSetRoot:=(RegSetValue(HKCR,Path,REG_SZ,Value,
lstrlen(Value))=ERROR_SUCCESS);
end;
function RegGetRoot(Path,Value:PChar; VL:Word):Boolean;
var {** OK für DLL **}
cb: LongInt;
begin
cb:=VL;
RegGetRoot:=(RegQueryValue(HKCR,Path,Value,cb)=ERROR_SUCCESS);
end;
function RegSetVal(Key:HKey;Path,Value:PChar):Boolean;
begin {** OK für DLL **}
RegSetVal:=(RegSetValue(Key,Path,REG_SZ,Value,
lstrlen(Value))=ERROR_SUCCESS);
end;
function RegGetVal(Key:HKey;Path,Value:PChar; VL:Word):Boolean;
var {** OK für DLL **}
cb: LongInt;
begin
cb:=VL;
RegGetVal:=(RegQueryValue(Key,Path,Value,cb)=ERROR_SUCCESS);
end;
function WriteProfileInt(Section,Key:PChar; Value:Integer):Bool;
{** OK für DLL **}
var
S: array[0..7]of Char;
begin
wvsprintf(S,'%d',Value);
WriteProfileInt:=WriteProfileString(Section,Key,S);
end;
function IsInvisible(c:Char):Boolean;
{liefert TRUE, wenn Zeichen im üblichen Windows-Zeichensatz nicht sichtbar}
begin
IsInvisible:=(c<' ') or (c>=#$80) and (c<#$A0) or (c=#$FF);
end;
function EscapeStr(src:PChar; slen:Word; dst:PChar; dlen:Word):Word;
{Wandelt übergebene "Bytefolge" (nicht nullterminiert) in C-String
mit Escape-Sequenzen um, auch \" und \' und \\. Nicht darstellbare
Zeichen werden in \a, \b usw. und ansonsten in Hex (\xXX) umgesetzt.
Liefert als Ergebnis die Länge des Ergebnisstrings ohne \0.
src und dst dürfen sich nicht überlappen.}
var
su: Char;
ChrCount: Word;
function fcat(template:PChar; len:Word):Boolean;
begin
fcat:=false;
if len<dlen then begin
if PtrRec(template).Sel<>0
then wvsprintf(dst,template,su)
else dst^:=su;
Inc(dst,len);
Inc(ChrCount,len);
Dec(dlen,len);
fcat:=true;
end;
end;
begin
ChrCount:=0;
while slen>0 do begin
su:=#0;
case src^ of
'\','"','''': su:=src^;
#7: su:='a';
#8: su:='b';
#9: su:='t';
#10: su:='n';
#11: su:='v';
#13: su:='r';
end;
if su<>#0 then begin
if not fcat('\%c',2) then break;
end else begin
su:=src^;
if IsInvisible(su) then begin
if not fcat('\x%02X',4) then break;
end else begin
if not fcat(nil,1) then break;
end;
end;
Inc(src);
Dec(slen);
end{while};
if dlen>0 then dst^:=#0; {terminieren}
EscapeStr:=ChrCount;
end;
function UnescapeStr(src, dst:PChar; dlen:Word):Word;
{Wandelt übergebenen C-String (nullterminiert) in "Bytefolge".
Liefert als Ergebnis die Länge der Ergebnis-Bytefolge -
diese ist nicht nullterminiert!
Da der Ergebnisstring niemals länger wird, darf src=dst sein.}
var
su,st: Char;
ChrCount: Word;
e,f: Integer;
begin
ChrCount:=0;
while dlen>0 do begin
su:=src^;
Inc(src);
if su=#0 then break;
if su='\' then begin
su:=src^;
Inc(src);
case su of
#0: break;
'0': su:=#0; {Hier: Keine Oktalzahlen - nur dieser Sonderfall}
'1'..'9': begin
Dec(src);
Val(src,Byte(su),e); {liefert als Fehler Zeichenpos+1!}
if e<>0 then begin
Dec(e);
st:=src[e];
src[e]:=#0;
Val(src,Byte(su),f); {sollte f=0 liefern, ist jedoch belanglos}
Inc(src,e);
src^:=st; {Zurückpatchen}
end else Inc(src,lstrlen(src)); {falls gerade am Stringende}
end;
'a': su:=#7;
'b': su:=#8;
't': su:=#9;
'n': su:=#10;
'v': su:=#11;
'r': su:=#13;
'x': begin
st:=src[2];
src[2]:=#0;
Dec(src);
src[0]:='$';
Val(src,Byte(su),e);
src[0]:='x'; {Zurückpatchen}
Inc(src);
src[2]:=st; {Zurückpatchen}
if e=0 then Inc(src,2) else su:='x';
end;
end{case}; {im ELSE-Fall bleibt "su" literal!}
end{if};
dst^:=su;
Inc(dst);
Inc(ChrCount);
Dec(dlen);
end;
UnescapeStr:=ChrCount;
end;
function _ldelete(S: PChar):Integer;
{** OK für DLL, nur kurze Dateinamen! **}
var
ReOpenBuf: TOfStruct;
begin
_lDelete:=OpenFile(S,ReOpenBuf,OF_Delete);
end;
procedure ShortYield;
{** OK für DLL **}
var
Msg: TMsg;
begin
if PeekMessage(Msg,0,0,0,PM_Remove) then begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
function lStrChr(Str:PChar; C:Char):PChar; assembler;
asm les ax,[Str]
mov dx,es
or dx,dx
jz @@n
jmp @@f
@@l: push dx
push ax
call AnsiNext
@@f: mov bx,ax
mov bl,es:[bx]
cmp bl,[C]
je @@e
or bl,bl
jnz @@l
@@n: xor ax,ax
cwd
@@e: end;
procedure Inc_SI_when_AL_DBCS; assembler;
asm pusha
push ax
call IsDbcsLeadByte
add ax,-1 {CY=1 wenn AX<>0}
popa
adc si,0
end;
function GetFileNamePtr(S:PChar):PChar; assembler;
{** OK für DLL **}
{liefert Zeiger hinter das letzte Auftreten von /\: oder Stringanfang}
asm les si,[S]
cld
@@ME: mov dx,si {Mögliches Ende merken}
@@l: seges lodsb
cmp al,'\'
jz @@ME
cmp al,'/'
jz @@ME
cmp al,':'
jz @@ME
or al,al
jz @@e
call Inc_SI_when_AL_DBCS
jmp @@l
@@e:
mov ax,es
xchg dx,ax
end;
function GetFileNameExt(S:PChar):PChar; assembler;
{** OK für DLL **}
{liefert Zeiger AUF DEN PUNKT oder AUF DIE TERMINIERENDE NULL, niemals NIL}
{Als Extension gilt hierbei die Zeichenkette beginnend am _letzten_
Punkt in der _letzten_ Pfadkomponente, wenn dieser Punkt nicht
am Anfang steht (wie bei den versteckten Dateien unter UNIX)
und auch nicht als Folge von Punkten am Anfang steht (wie bei ..)
*Voraussetzung für das korrekte Funktionieren dieser Funktion ist,
daß der Dateiname keinen anhängigen Pfad-Trenner (/\:) hat.}
{AH enthält: 0 für Pfadkomponentenanfang, 1 für andere Zeichen als /\:.,
≥2 für Punkt gefunden}
asm les si,[S]
cld
@@ME: xor ah,ah {AH=0 Pfadkomponente beginnt}
@@m1: mov dx,si
@@l: seges lodsb
cmp al,'\'
jz @@me {Neue Pfadkomponente: AH=0 setzen}
cmp al,'/'
jz @@me {dito}
cmp al,':'
jz @@me {dito}
cmp al,'.'
jz @@pt
or al,al
jz @@e {fertig}
call Inc_SI_when_AL_DBCS
cmp ah,2
jnc @@l {AH=2 (oder höher) nicht fertig und zuletzt '.'}
mov ah,1 {AH=1 setzen - zuletzt kein '\/:'}
jmp @@m1
@@pt:
or ah,ah {Null?}
jz @@m1 {kein Extensionspunkt am Anfang!}
inc ah {AH≥2 gültiger, aber vielleicht nicht finaler Punkt}
lea dx,[si-1]
jmp @@l {Adresse AUF den Punkt bleibt in DX stehen}
@@e: mov ax,es
xchg dx,ax
end;
function RemoveTrailSlash(S:PChar):PChar; assembler;
{** OK für DLL ** - NICHT für DBCS geeignet!}
{liefert Zeiger AUF DIE NULL, entfernt alle anhängenden Slashes}
asm les di,[S]
cld
xor ax,ax
mov dx,di
mov cx,$FFFF
repne scasb {ES:DI hinter die Null}
@@l: dec di {auf die Null}
cmp di,dx
je @@e
mov al,es:[di-1]
cmp al,'\'
jz @@l
cmp al,'/'
jz @@l
@@e:{Sonstiges Zeichen erreicht}
mov byte ptr es:[di],ah
mov dx,es
xchg ax,di
end;
procedure AnsiDosFunc; assembler;
{PE: DS:DX=Dateiname (wird ANSI2OEM-konvertiert mit dynamischer
Stackanforderung); sonstige Register außer BP werden durchgereicht
VR: DS,DX, weitere Register je nach DOS-Funktion}
asm push bp
mov bp,sp
{Register retten; Windows-Funktionen retten SI und DI selbst}
push ax
push bx
push cx
push es
{Länge ermitteln und Stack reservieren}
push dx {DX über's lstrlen hinüberretten}
push ds
push dx
call lstrlen {Namenslänge in AX}
pop dx
inc ax
inc ax
and al,not 1 {aufrunden und ausrichten}
sub sp,ax {dynamische Stack-Anforderung!!}
mov ax,sp {neuer Stringzeiger}
{String dahinein kopieren}
push ds
push dx {ds:dx=Quelle}
push ss
push ax {ss:ax=Ziel}
call AnsiToOem
{Register holen}
mov ax,[bp-2]
mov bx,[bp-4]
mov cx,[bp-6]
mov es,[bp-8]
{DOS rufen}
push ss
pop ds
mov dx,sp {ds:dx=konvertierter String}
stc
call Dos3Call
{fertig}
leave {sp:=bp, pop bp}
end;
procedure SortRect(var R:TRect); assembler;
{sortiert die Punkte, daß die Zuordnungen stimmen}
asm les bx,[R]
mov ax,es:TRect[bx].left
cmp ax,es:TRect[bx].right
jl @@1
xchg es:TRect[bx].right,ax
mov es:TRect[bx].left,ax
@@1: mov ax,es:TRect[bx].top
cmp ax,es:TRect[bx].bottom
jl @@2
xchg es:TRect[bx].bottom,ax
mov es:TRect[bx].top,ax
@@2: end;
procedure __AHShift; external 'KERNEL' index 113;
procedure __AHIncr; external 'KERNEL' index 114;
procedure __0000H; external 'KERNEL' index 183;
procedure __0040H; external 'KERNEL' index 193;
procedure __A000H; external 'KERNEL' index 174;
procedure __B000H; external 'KERNEL' index 181;
procedure __B800H; external 'KERNEL' index 182;
procedure __C000H; external 'KERNEL' index 195;
procedure __D000H; external 'KERNEL' index 179;
procedure __E000H; external 'KERNEL' index 190;
procedure __F000H; external 'KERNEL' index 194;
procedure __RomBios; external 'KERNEL' index 173;
procedure __WinFlags; external 'KERNEL' index 178;
function _hread; external 'KERNEL' index 349;
function _hwrite; external 'KERNEL' index 350;
procedure Throw; external 'KERNEL' index 56;
function GetProfileInt; external 'KERNEL' index 57;
function GetPrivateProfileInt; external 'KERNEL' index 127;
function _LocalLock; external 'KERNEL' index 8;
function SendMessageWW; external 'USER' index 111;
function SendMessageP; external 'USER' index 111;
function SendDlgItemMsgWW; external 'USER' index 101;
function SendDlgItemMsgP; external 'USER' index 101;
procedure CopyRect; external 'USER' index 74;
function IsRectEmpty; external 'USER' index 75;
function PtInRect; external 'USER' index 76;
function IntersectRect; external 'USER' index 79;
function UnionRect; external 'USER' index 80;
function FillRect; external 'USER' index 81;
procedure InvertRect; external 'USER' index 82;
procedure FrameRect; external 'USER' index 83;
function EqualRect; external 'USER' index 244;
function RegisterClass; external 'USER' index 57;
function ScrollDC; external 'USER' index 221;
procedure SetSysColors; external 'USER' index 181;
function TabbedTextOut; external 'USER' index 196;
function wsprintf; external 'USER' index 420;
function wvsprintf; external 'USER' index 421;
function CreatePolygonRgn; external 'GDI' index 63;
function CreatePolyPolygonRgn; external 'GDI' index 451;
function CreateRectRgnIndirect; external 'GDI' index 65;
function Polygon; external 'GDI' index 36;
function Polyline; external 'GDI' index 37;
function PolyPolygon; external 'GDI' index 450;
function RectInRegion; external 'GDI' index 181;
function RectVisible; external 'GDI' index 104;
function SetDIBits; external 'GDI' index 440;
function SetDIBitsToDevice; external 'GDI' index 443;
function StretchDIBits; external 'GDI' index 439;
function waveInClose; external 'MMSYSTEM' index 505;
function MMTaskCreate; external 'MMSYSTEM' index 900;
function MMTaskBlock; external 'MMSYSTEM' index 902;
function MMTaskSignal; external 'MMSYSTEM' index 903;
function MMGetCurrentTask; external 'MMSYSTEM' index 904;
procedure MMTaskYield; external 'MMSYSTEM' index 905;
function LocalLock(Mem: THandle): Pointer; assembler;
asm push Mem
call _LocalLock
mov dx,ds
end;
function GetDragClientFromPos(const P:TPoint):HWnd;
var
Wnd:HWnd;
begin
Wnd:=WindowFromPoint(P);
if Wnd<>0 then begin
if GetWindowLong(Wnd,GWL_ExStyle) and WS_EX_AcceptFiles =0
then Wnd:=0;
end;
GetDragClientFromPos:=Wnd;
end;
function PerformDrop(ToWnd:HWnd;argc:Integer;const argv:PChar):Bool;
{enthält Bugs!!}
var
HDrop: THandle;
dfsp: PDropFileStruct;
len: Word;
i: Integer;
ppc: ^PChar;
SP: PChar absolute dfsp;
begin
if ToWnd=0 then exit;
if argc<=0 then exit;
ppc:=@argv;
len:=sizeof(dfsp)-1;
for i:=1 to argc do begin
if ppc^=nil then exit;
Inc(len,lstrlen(ppc^)+1); {Gesamtlänge ermittlen}
Inc(ppc);
end;
HDrop:=GlobalAlloc(GMEM_Share or GMEM_Moveable, len);
dfsp:=GlobalLock(HDrop);
dfsp^.wSize:=8;
dfsp^.InNcArea:=Bool(SendMessage(ToWnd,WM_NcHitTest,0,LongInt(dfsp^.mPos))
<>HTClient);
ScreenToClient(ToWnd,dfsp^.mPos);
ppc:=@argv;
SP:=dfsp^.fNames;
for i:=1 to argc do begin
lstrcpy(SP,ppc^);
Inc(SP,lstrlen(ppc^));
SP^:=#0;
Inc(SP);
Inc(ppc);
end;
SP^:=#0;
GlobalUnlock(HDrop);
PostMessage(ToWnd,WM_DropFiles,HDrop,0);
end;
{IncHugePointer - Erhöhen eines Zeigers
auf Speicher mit mehr als 64 Kilobyte; Windows-Version mit AHIncr}
procedure IncHP(var P:PChar; By: Word); assembler;
asm
les di,[P] {Adresse von P}
mov ax,[By]
add es:PtrRec[di].Ofs,ax {Offset inkrementieren}
jnc @@e {kein Überlauf: Selektor belassen!}
add es:PtrRec[di].Sel,offset __AHIncr {Selektor erhöhen}
@@e:
end;
{DecHugePointer - Erniedrigen eines Zeigers
auf Speicher mit mehr als 64 Kilobyte; Windows-Version mit AHIncr}
procedure DecHP(var P:PChar; By: Word); assembler;
asm
les di,[P] {Adresse von P}
mov ax,[By]
sub es:PtrRec[di].Ofs,ax {Offset inkrementieren}
jnc @@e {kein Überlauf: Selektor belassen!}
sub es:PtrRec[di].Sel,offset __AHIncr {Selektor erniedrigen}
@@e:
end;
{IncHugePointerLong - Erhöhen und Erniedrigen eines Zeigers
auf Speicher mit mehr als 64 Kilobyte; Windows-Version mit AHIncr}
procedure IncHPL(var P:PChar; By: LongInt); assembler;
asm
les di,[P] {Adresse von P}
mov cx,LongRec[By].Lo {Hier AX:CX: ungewöhnlich!}
mov ax,LongRec[By].Hi
add es:PtrRec[di].Ofs,cx {Offset inkrementieren}
adc ax,0 {Anzahl der 64-K-Übergänge}
mov cx,offset __AHShift
shl ax,cl {Vielfaches erzeugen}
add es:PtrRec[di].Sel,ax {Selektor erhöhen bzw. erniedrigen}
end;
{TransparentBlt: von der MSDN-Library-CD
kopiert Bitmap unter Angabe einer tranparenten Farbe (TColorRef)
in einen Zielkontext. Dreh- und Angelpunkt ist der korrekte ROP.
PE: DC: Zielgerätekontext
x,y: Ziel-Koordinaten linke obere Ecke
hBm: Quell-Bitmap
cr: Transparente Farbe}
procedure TransparentBlt(DC:HDC; x,y:Integer; HBM:HBitmap; cr:TColorRef);
const ROP_DSPDxax=$00E20746;
var
hDCSrc,hDCMid: HDC;
hBmpMono: HBitmap;
hBrT: HBrush;
crBack,crText: TColorRef;
bm: TBitmap;
begin
if HBM<>0 then begin
GetObject(hBM,sizeof(bm),@bm);
hDCSrc:=CreateCompatibleDC(DC);
hDCMid:=CreateCompatibleDC(DC);
hBmpMono:=CreateCompatibleBitmap(hDCMid,bm.bmWidth,bm.bmHeight);
SelectObject(hDCSrc,hBm);
SelectObject(hDCMid,hBmpMono);
crBack:=SetBkColor(hDCSrc,cr);
BitBlt(hDCMid,0,0,bm.bmWidth,bm.bmHeight,hDCSrc,0,0,SrcCopy);
SetBkColor(hDCSrc,crBack);
BitBlt(DC,x,y,bm.bmWidth,bm.bmHeight,hDCSrc,0,0,SrcCopy);
hBrT:=SelectObject(DC,CreateSolidBrush(GetBkColor(DC)));
crText:=SetTextColor(DC,$000000);
crBack:=SetBkColor(DC,$FFFFFF);
BitBlt(DC,x,y,bm.bmWidth,bm.bmHeight,hDCMid,0,0,ROP_DSPDxax);
SetTextColor(DC,crText);
SetBkColor(DC,crBack);
DeleteObject(SelectObject(DC,hBrT));
DeleteDC(hDCSrc);
DeleteDC(hDCMid);
DeleteObject(hBmpMono);
end;
end;
{Funktionskompatibel zur Win32-API, unterstützt lange Dateinamen}
function CopyFile(NameS,NameD:PChar; Overwrite: Bool):Bool;
label
ex1, ex2, ex3;
const
BUFSIZE=$4000;
var
OK: Bool;
Buf: PChar; {hier: 16K-Cluster}
fs,fd: Integer;
BytesRead: Integer;
begin
OK:=false;
fs:=_lopen(NameS,OF_Share_Compat);
if fs=-1 then fs:=_lopen(NameS,OF_Share_Deny_Write);
if fs=-1 then goto ex1;
if not Overwrite then begin
fd:=_lopen(NameD,OF_Share_Compat);
if fd<>-1 then goto ex2;
end;
fd:=_lcreat(NameD,0);
if fd=-1 then goto ex2;
Buf:=Ptr(GlobalAlloc(GMEM_Fixed,BUFSIZE),0);
if PtrRec(Buf).sel=0 then goto ex2;
repeat
BytesRead:=_lread(fs,Buf,BUFSIZE);
if Integer(_lwrite(fd,Buf,BytesRead))<>BytesRead then goto ex3;
until BytesRead=0;
GlobalFree(PtrRec(Buf).sel);
asm mov ax,5700h {Datum/Uhrzeit lesen}
mov bx,[fs]
call Dos3Call
jc ex3
inc al {Datum/Uhrzeit setzen}
mov bx,[fd]
call Dos3Call
jc ex3
end;
OK:=true;
ex3: OK:=(_lclose(fd)<>-1) and OK;
ex2: OK:=(_lclose(fs)<>-1) and OK;
ex1: CopyFile:=OK;
end;
{GetDriveTypeEx: Laufwerkstyp ermitteln, mit CD-ROM und RAM
PE: Drv: Nullbasierter Laufwerks-Index
PA: Einer der Werte:
Drive_Removable, Drive_Fixed, Drive_Remote, Drive_CDROM, Drive_RAM}
function GetDriveTypeEx(Drv:Integer):Word; assembler;
asm
push [Drv]
call GetDriveType
cmp ax,Drive_Fixed
jz @@TestCD
cmp ax,Drive_Remote
jnz @@SkipCD
@@TestCD:
push ax
mov ax,$1500
xor bx,bx
int $2f {Test MSCDEX-Präsenz}
or bx,bx
jz @@NoCD
mov ax,$150B
mov cx,[Drv]
int $2f {Test Laufwerk=CD-ROM?}
or ax,ax
jz @@NoCD
pop ax
push Drive_CDROM
@@NoCD:
@@SkipCD:
pop ax
cmp ax,Drive_Fixed
jnz @@SkipRAM
push ax
push ds
push ss
pop ds
sub sp,$200 {Dynamische Stackreservierung zum Sektorlesen}
mov bx,sp {BX=Sektorzeiger}
mov ax,[Drv]
mov cx,1 {Anzahl=1}
xor dx,dx {Sektor 0}
int $25
jc @@NoRAM
mov bx,sp {Achtung: BX ist 2 tiefergelegt!}
{ cmp byte ptr ss:[bx+$17],$f8 {Nochmals auf "Festplatte" testen}
{ jne @@NoRAM ... funktioniert nicht mit TDSK!}
cmp byte ptr ss:[bx+$12],1 {Eine FAT?}
jne @@NoRAM
mov word ptr ss:[bx+$204],Drive_RAM {gepushtes AX verändern!!}
@@NoRAM:
add sp,$202 {Stack freigeben, 2 mehr wegen Int25}
pop ds
pop ax
@@SkipRAM:
end;
{Zentriert Wnd im Elternfenster oder Desktopfenster}
procedure CenterDlg(Wnd:HWnd); assembler;
var
R: TRect;
asm mov si,sp {Rechteck Dialog und Desktop}
push [Wnd]
call GetParent
or ax,ax
jnz @@1
call GetDesktopWindow
@@1: push ax
push ss
push si {für GetDesktopWindowRect}
push [Wnd]
push ss
push si
call GetWindowRect
mov si,[R.right]
sub si,[R.left] {SI=neues R.width}
mov di,[R.bottom]
sub di,[R.top] {DI=neues R.height}
call GetWindowRect
push [Wnd]
mov ax,[R.right] {R.left sollte 0 sein}
sub ax,si
sar ax,1
push ax {neues R.left (X)}
mov ax,[R.bottom] {R.top sollte 0 sein}
sub ax,di
sar ax,1
push ax {neues R.top (Y)}
push si {width}
push di {height}
push 1 {fRepaint}
call MoveWindow
end;
function FirstWord(var S:PChar;Delim:Word):PChar; assembler;
{TOTAL FEHLERHAFT!}
var
StartPos,EndPos:Word;
TermChar:Char;
InQuote:Boolean;
asm push ds
les di,S
mov cx,[Delim]
mov [TermChar],cl {Zunächst Endezeichen}
mov [InQuote],0
lds si,es:[di]
cld
@@tl: mov [StartPos],si {Startposition im Stack merken}
lodsb
cmp al,0
jz @@end
cmp al,' '
jz @@lspc
cmp al,9
jz @@lspc
cmp al,10
jz @@lspc0
cmp al,13
jz @@lspc0
cmp al,'"'
jz @@DQ
cmp al,''''
jz @@SQ
{Sonstiger Buchstabe}
@@l:
push ax
call IsDBCSLeadByte
add ax,-1 {0-->CY=0}
adc si,0 {sprungfrei bedingt inkrementieren}
lodsb
cmp al,0
jz @@end
cmp al,[TermChar]
jz @@term
cmp al,' '
jz @@rspc
cmp al,9
jz @@rspc
cmp al,10
jz @@rspc0
cmp al,13
jz @@rspc0
@@te:
mov dx,ds
mov ax,[StartPos]
pop ds
jmp @@e
@@lspc0: test ch,$40 {Zeilenendezeichen erlaubt?}
jz @@l {nein}
@@lspc: test ch,1 {TrimLeft}
jz @@l {nein, als Buchstabe auffassen}
jmp @@tl {ja, weiter in TrimLeft}
@@DQ: test ch,4
jz @@l {nein, als Buchstabe auffassen}
mov [TermChar],'"'
jmp @@l0
@@SQ: test ch,8
jz @@l
mov [TermChar],''''
@@l0: mov [StartPos],si {Start ist HINTER dem Qu(ix)ote}
or [InQuote],1
jmp @@l
@@term: test [InQuote],1
jnz @@t1
lea bx,[si-1]
mov byte ptr [bx],0
mov es:[di],bx
jmp @@te
@@rspc0:
@@rspc:
@@t1:
@@end:
@@e: end;
procedure StrDisposeNoDS(var SP:PChar);
begin
if Seg(SP^)<>Seg(HInstance) then StrDispose(SP);
SP:=nil;
end;
function Str2XX(S:PChar; var P; Size:Word):Boolean;
var
HL: LongInt;
EC: Integer;
begin
Str2XX:=false;
case Size of
GX_Long: begin
Val(S,HL,EC); {VAL setzt bei Fehler Ziel auf 0, daher Hilfsvariable}
if EC=0 then begin
LongInt(P):=HL;
Str2XX:=true;
end;
end;
end;
end;
{Kapselfunktionen, die je nach StdProfile die WIN.INI oder eine private
.INI modifizieren. Zugriff auf die WIN.INI mit xxxPrivatexxx ist
gefährlich, da USER.EXE die WIN.INI dann 2x im Cache hält...}
function GetPrfInt(Sec,Key:PChar; Def:Integer):Integer; near; assembler;
asm pop bp {Pascal-Ärger!}
pop si {Returnadresse}
les di,[StdProfile]
mov cx,es
jcxz @@winini
push es; push di
call GetPrivateProfileInt
jmp si
@@winini:
call GetProfileInt
jmp si
end;
function GetPrfString(Sec,Key,Def,S:PChar;size:Integer):Integer; near;
assembler;
asm pop bp {Pascal-Ärger!}
pop si {Returnadresse}
les di,[StdProfile]
mov cx,es
jcxz @@winini
push es; push di
call GetPrivateProfileString
jmp si
@@winini:
call GetProfileString
jmp si
end;
function WritePrfString(Sec,Key,S:PChar):Bool; near; assembler;
asm pop bp {Pascal-Ärger!}
pop si {Returnadresse}
les di,[StdProfile]
mov cx,es
jcxz @@winini
push es; push di
call WritePrivateProfileString
jmp si
@@winini:
call WriteProfileString
jmp si
end;
function GetPrfXX(Section,Key:PChar; var P; Size:Word):Boolean;
var
S: array[0..1023] of Char; {ich glaube, GetXXString liefert nicht mehr}
begin
GetPrfXX:=false;
case Size of
GX_Int,GX_Word: begin
Integer(P):=GetPrfInt(Section,Key,Integer(P));
GetPrfXX:=true;
end;
0: begin
GetPrfString(Section,Key,PChar(P),S,sizeof(S));
if (PChar(P)=nil) or (lstrcmp(PChar(P),S)<>0) then begin
StrDisposeNoDS(PChar(P));
PChar(P):=StrNew(S); {schöne Schaufelei!}
end;
GetPrfXX:=true;
end;
2..$EFFF: begin
GetPrfString(Section,Key,PChar(@P),PChar(@P),Size);
GetPrfXX:=true;
end;
else begin
GetPrfString(Section,Key,'',S,sizeof(S));
GetPrfXX:=Str2XX(S,P,Size);
end;
end;
end;
function SetPrfXX(Section,Key:PChar; const P; T:PChar):Boolean;
var
S: array[0..1023] of Char;
begin
if T<>nil then begin
wvsprintf(S,T,P);
WritePrfString(Section,Key,S);
end else begin
WritePrfString(Section,Key,PChar(@P));
end;
end;
function GetWndXX(Wnd:HWnd; var P; Size:Word):Boolean;
var
W: Word;
S: array[0..255]of Char;
begin
GetWndXX:=true;
case Size of
0: begin
StrDisposeNoDS(PChar(P));
W:=Word(GetWindowTextLength(Wnd))+1;
GetMem(PChar(P),W);
GetWindowText(Wnd,PChar(P),W);
end;
2..$EFFF: begin
GetWindowText(Wnd,PChar(@P),Size);
end;
else begin
GetWindowText(Wnd,S,sizeof(S));
GetWndXX:=Str2XX(S,P,Size);
end;
end;
end;
function GetDlgItemXX(Wnd:HWnd; ID:Word; var P; Size:Word):Boolean;
var
B: Bool;
W: Word;
begin
case Size of
GX_Int: begin
Integer(W):=GetDlgItemInt(Wnd,ID,@B,true);
if B then Integer(P):=Integer(W);
GetDlgItemXX:=B;
end;
GX_Word: begin
W:=GetDlgItemInt(Wnd,ID,@B,true);
if B then Word(P):=W;
GetDlgItemXX:=B;
end;
else begin
GetDlgItemXX:=GetWndXX(GetDlgItem(Wnd,ID),P,Size);
end;
end;
end;
function GetModuleDescription(FName,Descript:PChar):Boolean;
{extrahiert aus Windows-EXE Modulbeschreibung, mit OEM->ANSI
FName darf alternativ ein geöffnetes Datei-Handle sein (Dateipos=0!),
Descript muß auf einen Puffer mit mindestens 256 Bytes zeigen}
const
MZ=$5A4D;
NE=$454E;
label
finally;
var
f: Integer absolute FName;
L: LongInt;
LR: LongRec absolute L;
W: Word absolute L;
B: Byte absolute L;
begin
GetModuleDescription:=false;
if PtrRec(FName).Sel<>0
then f:=_lopen(FName,0); {Share-Modus richtig?}
if f=0 then exit; {falls NIL übergeben wurde}
if f=-1 then exit; {falls das Öffnen fehlschlug}
_lread(f,PChar(@W),2);
if W<>MZ then goto finally;
_llseek(f,$18,0);
_lread(f,PChar(@W),2);
if W<>$0040 then goto finally;
_llseek(f,$3C,0);
_lread(f,PChar(@L),4); {neuer Dateioffset}
_llseek(f,L,0);
if _lread(f,PChar(@W),2)<>2 then goto finally;
if W<>NE then goto finally;
_llseek(f,$2A,1); {42 Bytes hinter NE}
_lread(f,PChar(@L),4); {Dateioffset des Pascal-Strings}
_llseek(f,L,0);
if _lread(f,PChar(@B),1)<>1 then goto finally;
if B=0 then goto finally;
W:=B;
if _lread(f,Descript,W)<>W then goto finally;
for LR.Hi:=0 to W-1 do if Descript[LR.Hi]<' ' then goto finally;
Descript[W]:=#0; {terminieren}
OemToAnsi(Descript,Descript);
GetModuleDescription:=true;
finally:
if PtrRec(FName).Sel<>0
then _lclose(f);
end;
procedure memmove(d,s:Pointer; l:Word); assembler;
asm cld
push ds
lds si,[s]
les di,[d]
mov cx,[l]
cmp si,di
jnc @@up
dec cx
add si,cx
add di,cx
inc cx
std
@@up: rep movsb
pop ds
cld
end;
end.
{Müll}
type
TMemTextParse=record
a,c,e,max:PChar;
{a=Anfang, c=Cursor, e=Text-Ende, max=Speicher-Ende}
end;
function IsCharWhite(C:Char):Bool;
function NextLine(var mtp:TMemTextParse):Boolean;
{...verschiebt den Cursor auf den Anfang der nächsten Zeile}
function DelLine(var mtp:TMemTextParse):Boolean;
{...löscht die Zeile ab Cursor inkusive CRLF}
function InsertLine(var mtp:TMemTextParse; S:PChar):Boolean;
{...fügt eine Zeile ab Cursor inklusive CRLF ein}
function GetTrimmedLine(var mtp:TMemTextParse; S:PChar; SL:Word):Boolean;
{...holt eine Zeile, die von Leerzeichen an Anfang und Ende befreit ist}
{Speichertextverwaltungs-Funktionen}
function IsCharWhite(C:Char):Bool;
begin
IsCharWhite:= (C=' ')or(C=#9);
end;
function NextLine(var mtp:TMemTextParse):Boolean;
begin
NextLine:=false;
if mtp.c=mtp.e then exit; {Keine neue Zeile folgt}
while mtp.c^<>#10 do begin
mtp.c:=AnsiNext(mtp.c);
if mtp.c=mtp.e then exit; {Keine neue Zeile folgt}
end;
if ((mtp.c=mtp.a) or ((mtp.c-1)^<>#13)) {wenn kein #13 davor...}
and ((mtp.c+1)^=#13) {dann vielleicht dahinter...}
then Inc(mtp.c); {dann ist DIES das Zeilenende!}
Inc(mtp.c); {Der neue Zeilenanfang}
if mtp.c=mtp.e then exit; {keine echte Zeile!}
NextLine:=true;
end;
function DelLine(var mtp:TMemTextParse):Boolean;
var
c1: PChar;
begin
DelLine:=false;
c1:=mtp.c; {Cursor merken}
if c1=mtp.e then exit; {Nichts zu löschen da!}
NextLine(mtp); {Cursor auf neue Zeile}
Move(mtp.c,c1,mtp.e-mtp.c); {"Schwanz" bewegen}
Dec(mtp.e,mtp.c-c1); {Ende verkürzen}
mtp.c:=c1; {Cursor setzen}
DelLine:=true;
end;
function InsertLine(var mtp:TMemTextParse; Key,Value:PChar):Boolean;
var
len: Word;
LenKey,LenVal:Word;
begin
InsertLine:=false;
if Key=nil then exit;
LenKey:=lStrLen(Key);
len:=KenKey+3; {Einfüge-Länge}
LenVal:=$FFFF; if Value<>nil then LenVal:=lstrlen(Value);
Inc(len,LenVal); {aus Key und Value}
if mtp.max<mtp.e+len then exit; {Speichermangel}
Move(mtp.c,mtp.c+len,mtp.e-mtp.c); {"Schwanz" bewegen}
Inc(mtp.e,len); {Ende verlängern}
Move(Key,mtp.c,LenKey);
Inc(mtp.c,LenKey);
if LenVal<>$FFFF then begin
mtp.c^:='=';
Inc(mtp.c);
Move(Value,mtp.c,LenVal);
Inc(mtp.c,LenVal);
end;
PWord(mtp.c-2)^:=#1013; {CRLF einpatchen}
Inc(mtp.c,2); {Cursor dahinter}
InsertLine:=true;
end;
function GetIniLine(var mtp:TMemTextParse; Sec,Key,Value:PChar; VL:Word):Boolean;
var
c1,c2,c3: PChar;
begin
GetTrimmedLine:=false;
if mtp.c=mtp.e then exit; {Ende erreicht}
c1:=mtp.c; {Cursor merken}
NextLine(mtp); {Nächste Zeile oder Ende ansteuern}
c3:=mtp.c; {"Hilfs-Ende"}
while (c1<mtp.c) and IsCharWhite(c1^) do Inc(c1); {"TrimLeft"}
if (c1<mtp.c) and c1^='[' then
while c1<c3 do begin
c2:=AnsiPrev(c1,c3);
if IsCharWhite(c2^) or (c2^=#13) or (c2^=#10)
then c3:=c2; {weitermachen}
else break; {Stop, c3 zeigt aufs String-Ende}
end;
if SL>c3-c1 then SL:=c3-c1;
lstrcpyn(S,c1,SL);
GetTrimmedLine:=true;
end;
| Detected encoding: OEM (CP437) | 1
|
|
|
![[Download]](icons/dl.gif){kind=icon}
kcemu_052.exe/SRC/WUTILS.PAS