mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-01 18:06:03 +02:00
+ Initial implementation; Donated by Gertjan Schouten
His file was split into several files, to keep it a little bit structured.
This commit is contained in:
michael
parent
b7ff96bb48
commit
80e4fa2639
309
rtl/objpas/dati.inc
Normal file
309
rtl/objpas/dati.inc
Normal file
@ -0,0 +1,309 @@
|
||||
{
|
||||
*********************************************************************
|
||||
$Id$
|
||||
Copyright (C) 1997, 1998 Gertjan Schouten
|
||||
|
||||
This program 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 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
*********************************************************************
|
||||
|
||||
System Utilities For Free Pascal
|
||||
}
|
||||
|
||||
{ date time functions }
|
||||
|
||||
function IsLeapYear(Year: Word): Boolean;
|
||||
begin
|
||||
IsLeapYear := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
|
||||
end;
|
||||
|
||||
function DoEncodeDate(Year, Month, Day: Word):longint;
|
||||
var
|
||||
I: Longint;
|
||||
begin
|
||||
DoEncodeDate := 0;
|
||||
if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and
|
||||
(Day >= 1) and (Day <= 31) then begin
|
||||
Day := Day + DayTable[IsLeapYear(Year), Month] - 1;
|
||||
I := Year - 1;
|
||||
DoEncodeDate := I * 365 + I div 4 - I div 100 + I div 400 + Day;
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function doEncodeTime(Hour,Minute,Second,MilliSecond:word):longint;
|
||||
begin
|
||||
doEncodeTime := (Hour * 3600000 + Minute * 60000 + Second * 1000 + MilliSecond) { div MSecsPerDay} ;
|
||||
end ;
|
||||
|
||||
function DateToStr(Date:TDateTime):string;
|
||||
begin
|
||||
DateToStr := FormatDateTime('c', Date);
|
||||
end ;
|
||||
|
||||
function TimeToStr(Time:TDateTime):string;
|
||||
begin
|
||||
TimeToStr := FormatDateTime('t', Time);
|
||||
end ;
|
||||
|
||||
function DateTimeToStr(DateTime:TDateTime):string;
|
||||
begin
|
||||
DateTimeToStr := FormatDateTime('c t', DateTime);
|
||||
end ;
|
||||
|
||||
function EncodeDate(Year, Month, Day :word):TDateTime;
|
||||
begin
|
||||
EncodeDate := DoEncodeDate(Year, Month, Day);
|
||||
end ;
|
||||
|
||||
function EncodeTime(Hour, Minute, Second, MilliSecond:word):TDateTime;
|
||||
begin
|
||||
EncodeTime := doEncodeTime(hour, minute, second, millisecond) / MSecsPerDay;
|
||||
end ;
|
||||
|
||||
procedure DecodeDate(Date:TDateTime;var Year:word;var Month:word;var Day:word);
|
||||
const
|
||||
D1 = 365; { number of days in 1 year }
|
||||
D4 = D1 * 4 + 1; { number of days in 4 years }
|
||||
D100 = D4 * 25 - 1; { number of days in 100 years }
|
||||
D400 = D100 * 4 + 1; { number of days in 400 years }
|
||||
var
|
||||
i:Longint;
|
||||
l:longint;
|
||||
ly:boolean;
|
||||
begin
|
||||
l := Trunc(Int(Date));
|
||||
year := 1 + 400 * (l div D400); l := (l mod D400);
|
||||
year := year + 100 * (l div D100);l := (l mod D100);
|
||||
year := year + 4 * (l div D4);l := (l mod D4);
|
||||
year := year + (l div D1);l := 1 + (l mod D1);
|
||||
month := 0;
|
||||
ly := IsLeapYear(Year);
|
||||
while (month < 12) and (l > DayTable[ly, month + 1]) do
|
||||
inc(month);
|
||||
day := l - DayTable[ly, month];
|
||||
end ;
|
||||
|
||||
procedure DecodeTime(Time:TDateTime;var Hour:word;var Minute:word;var Second:word;var MilliSecond:word);
|
||||
var l:longint;
|
||||
begin
|
||||
l := Trunc(Frac(time) * MSecsPerDay);
|
||||
Hour := l div 3600000;l := l mod 3600000;
|
||||
Minute := l div 60000;l := l mod 60000;
|
||||
Second := l div 1000;l := l mod 1000;
|
||||
MilliSecond := l;
|
||||
end ;
|
||||
|
||||
function FormatDateTime(formatstr:string;DateTime:TDateTime):string;
|
||||
var i:longint;result:string;current:string;e:longint;
|
||||
y,m,d,h,n,s,ms:word;
|
||||
mDate, mTime:double;
|
||||
begin
|
||||
mDate := int(DateTime);
|
||||
mTime := frac(DateTime);
|
||||
DecodeDate(mDate, y, m, d);
|
||||
DecodeTime(mTime, h, n, s, ms);
|
||||
result := '';
|
||||
current := '';
|
||||
i := 1;
|
||||
e := 0;
|
||||
while not(i > length(formatstr)) do begin
|
||||
while not(formatstr[i] in [' ','"','/',':','''']) and not(i > length(formatstr)) do begin
|
||||
current := current + formatstr[i];
|
||||
inc(i);
|
||||
end ;
|
||||
if ((current = 'a') or (current = 'am')) and (formatstr[i] = '/') then begin
|
||||
inc(i);current := current + '/';
|
||||
while not(formatstr[i] in [' ','"','/',':','''']) and not(i > length(formatstr)) do begin
|
||||
current := current + formatstr[i];
|
||||
inc(i);
|
||||
end ;
|
||||
end ;
|
||||
if not(current = '') then begin
|
||||
if (current = 'c') then begin
|
||||
i := 1; result := ''; current := '';
|
||||
formatstr := ' ' + shortdateformat + '" "' + shorttimeformat;
|
||||
end ;
|
||||
if not(mTime = 0) then begin
|
||||
if (current = 't') then begin
|
||||
formatstr := ' ' + shorttimeformat + copy(formatstr, i, length(formatstr));
|
||||
i := 1;
|
||||
end
|
||||
else if (current = 'tt') then begin
|
||||
formatstr := ' ' + longtimeformat + copy(formatstr,i,length(formatstr));
|
||||
i := 1;
|
||||
end
|
||||
else if (current = 'h') then result := result + inttostr(h)
|
||||
else if (current = 'hh') then result := result + right('0'+inttostr(h),2)
|
||||
else if (current = 'n') then result := result + inttostr(n)
|
||||
else if (current = 'nn') then result := result + right('0'+inttostr(n),2)
|
||||
else if (current = 's') then result := result + inttostr(s)
|
||||
else if (current = 'ss') then result := result + right('0'+inttostr(s),2)
|
||||
else if (current = 'am/pm') then begin
|
||||
if (h < 13) then result := result + 'am'
|
||||
else result := result + 'pm';
|
||||
end
|
||||
else if (current = 'a/p') then begin
|
||||
if h < 13 then result := result + 'a'
|
||||
else result := result + 'p';
|
||||
end
|
||||
else if (current = 'ampm') then begin
|
||||
if h < 13 then strCat(result, TimeAMString)
|
||||
else strCat(result, TimePMString);
|
||||
end ;
|
||||
end ;
|
||||
if not(mDate = 0) then begin
|
||||
if (current = 'd') then result := result + inttostr(d)
|
||||
else if (current = 'dd') then result := result + right('0' + inttostr(d), 2)
|
||||
else if (current = 'ddd') then StrCat(result, shortdaynames[DayOfWeek(DateTime)])
|
||||
else if (current = 'dddd') then StrCat(result, longdaynames[DayOfWeek(DateTime)])
|
||||
else if (current = 'm') then result := result + inttostr(m)
|
||||
else if (current = 'mm') then result := result + right('0' + inttostr(m), 2)
|
||||
else if (current = 'mmm') then StrCat(result, shortmonthnames[m])
|
||||
else if (current = 'mmmm') then StrCat(result, longmonthnames[m])
|
||||
else if (current = 'y') then result := result + inttostr(y)
|
||||
else if (current = 'yy') then result := result + right(inttostr(y), 2)
|
||||
else if (current = 'yyyy') or (current = 'yyy') then result := result + inttostr(y);
|
||||
end ;
|
||||
current := '';
|
||||
end ;
|
||||
if (formatstr[i] = '/') and not(mDate = 0) then result := result + dateseparator
|
||||
else if (formatstr[i] = ':') and not(mTime = 0) then result := result + timeseparator
|
||||
else if (formatstr[i] in ['"','''']) then begin
|
||||
inc(i);
|
||||
while not(formatstr[i] in ['"','''']) and not(i > length(formatstr)) do begin
|
||||
result := result + formatstr[i];
|
||||
inc(i);
|
||||
end ;
|
||||
end ;
|
||||
inc(i);
|
||||
end ;
|
||||
FormatDateTime := Result;
|
||||
end ;
|
||||
|
||||
function StrToDate(const s:string):TDateTime;
|
||||
var
|
||||
df:string;
|
||||
d,m,y:word;n,i:longint;c:word;
|
||||
s1:string[4];
|
||||
values:array[0..2] of longint;
|
||||
LocalTime:tsystemtime;
|
||||
begin
|
||||
df := UpperCase(ShortDateFormat);
|
||||
d := 0;m := 0;y := 0;
|
||||
for i := 0 to 2 do values[i] := 0;
|
||||
s1 := '';
|
||||
n := 0;
|
||||
for i := 1 to length(s) do begin
|
||||
if (s[i] in ['0'..'9']) then s1 := s1 + s[i];
|
||||
if (s[i] in [dateseparator,' ']) or (i = length(s)) then begin
|
||||
val(s1, values[n], c);
|
||||
s1 := '';
|
||||
inc(n);
|
||||
end ;
|
||||
end ;
|
||||
if (df = 'D/M/Y') then begin
|
||||
d := values[0];
|
||||
m := values[1];
|
||||
y := values[2];
|
||||
end
|
||||
else if (df = 'M/D/Y') then begin
|
||||
if (n > 1) then begin
|
||||
m := values[0];
|
||||
d := values[1];
|
||||
y := values[2];
|
||||
end
|
||||
else { if there is just one value, it is the day of the month }
|
||||
d := values[0];
|
||||
end
|
||||
else if (df = 'Y/M/D') then begin
|
||||
if (n = 3) then begin
|
||||
y := values[0];
|
||||
m := values[1];
|
||||
d := values[2];
|
||||
end
|
||||
else if (n = 2) then begin
|
||||
m := values[0];
|
||||
d := values[1];
|
||||
end
|
||||
else if (n = 1) then
|
||||
d := values[0];
|
||||
end ;
|
||||
if (n < 3) then begin
|
||||
getLocalTime(LocalTime);
|
||||
y := LocalTime.wYear;
|
||||
if (n < 2) then
|
||||
m := LocalTime.wMonth;
|
||||
end ;
|
||||
if (y >= 0) and (y < 100) then y := 1900 + y;
|
||||
StrToDate := DoEncodeDate(y, m, d);
|
||||
end ;
|
||||
|
||||
function StrToTime(const s:string):TDateTime;
|
||||
begin
|
||||
end ;
|
||||
|
||||
function StrToDateTime(const s:string):TDateTime;
|
||||
begin
|
||||
end ;
|
||||
|
||||
function DayOfWeek(DateTime:TDateTime):longint;
|
||||
begin
|
||||
DayOfWeek := (1 + Trunc(DateTime)) mod 7;
|
||||
end ;
|
||||
|
||||
procedure getlocaltime(var systemtime:tsystemtime);
|
||||
var wDayOfWeek:word;
|
||||
begin
|
||||
getdate(systemtime.wYear,
|
||||
systemtime.wMonth,
|
||||
systemtime.wDay,
|
||||
wDayOfWeek);
|
||||
gettime(systemtime.whour,
|
||||
systemtime.wminute,
|
||||
systemtime.wsecond,
|
||||
systemtime.wmillisecond);
|
||||
systemtime.wmillisecond := systemtime.wmillisecond * 10;
|
||||
end ;
|
||||
|
||||
function Date:TDateTime;
|
||||
var systemtime:tsystemtime;
|
||||
begin
|
||||
getlocaltime(systemtime);
|
||||
date := doEncodeDate(systemtime.wYear,systemtime.wMonth,systemtime.wDay);
|
||||
end ;
|
||||
|
||||
function Time:TDateTime;
|
||||
var systemtime:tsystemtime;
|
||||
begin
|
||||
getlocaltime(systemtime);
|
||||
time := doEncodeTime(systemtime.wHour,systemtime.wMinute,
|
||||
systemtime.wSecond,systemtime.wMillisecond) / MSecsPerDay;
|
||||
end ;
|
||||
|
||||
function Now:TDateTime;
|
||||
var systemtime:tsystemtime;
|
||||
begin
|
||||
getlocaltime(systemtime);
|
||||
now := doEncodeDate(systemtime.wYear,systemtime.wMonth,systemtime.wDay) +
|
||||
doEncodeTime(systemtime.wHour,systemtime.wMinute,
|
||||
systemtime.wSecond,systemtime.wMillisecond) / MSecsPerDay;
|
||||
end ;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-04-10 15:17:46 michael
|
||||
+ Initial implementation; Donated by Gertjan Schouten
|
||||
His file was split into several files, to keep it a little bit structured.
|
||||
|
||||
}
|
||||
119
rtl/objpas/datih.inc
Normal file
119
rtl/objpas/datih.inc
Normal file
@ -0,0 +1,119 @@
|
||||
{
|
||||
*********************************************************************
|
||||
$Id$
|
||||
Copyright (C) 1997, 1998 Gertjan Schouten
|
||||
|
||||
This program 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 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
*********************************************************************
|
||||
|
||||
System Utilities For Free Pascal
|
||||
}
|
||||
|
||||
|
||||
const
|
||||
SecsPerDay = 24 * 60 * 60; // Seconds and milliseconds per day
|
||||
MSecsPerDay = SecsPerDay * 1000;
|
||||
|
||||
DateDelta = 693594; // Days between 1/1/0001 and 12/31/1899
|
||||
DateSeparator:char='-';
|
||||
TimeSeparator:char=':';
|
||||
TimeAMString: pchar = 'am';
|
||||
TimePMString: pchar = 'pm';
|
||||
ShortMonthNames: array[1..12] of pchar =
|
||||
('jan','feb','mar','apr','mai','jun',
|
||||
'jul','aug','sep','oct','nov','dec');
|
||||
LongMonthNames: array[1..12] of pchar=
|
||||
('january','february','march','april','mai','june',
|
||||
'july','august','september','october','november','december');
|
||||
ShortDayNames: array[1..7] of pchar=
|
||||
('sun','mon','tue','wen','thu','fri','sat');
|
||||
LongDayNames: array[1..7] of pchar=
|
||||
('sunday','monday','tuesday','wednesday','thursday','friday','saturday');
|
||||
|
||||
{ date time formatting characters:
|
||||
c : shortdateformat + ' ' + shorttimeformat
|
||||
d : day of month
|
||||
dd : day of month (leading zero)
|
||||
ddd : day of week (abbreviation)
|
||||
dddd : day of week (full)
|
||||
ddddd : shortdateformat
|
||||
dddddd : longdateformat
|
||||
m : month
|
||||
mm : month (leading zero)
|
||||
mmm : month (abbreviation)
|
||||
mmmm : month (full)
|
||||
y : year (four digits)
|
||||
yy : year (two digits)
|
||||
yyyy : year (with century)
|
||||
h : hour
|
||||
hh : hour (leading zero)
|
||||
n : minute
|
||||
nn : minute (leading zero)
|
||||
s : second
|
||||
ss : second (leading zero)
|
||||
t : shorttimeformat
|
||||
tt : longtimeformat
|
||||
am/pm : use 12 hour clock and display am and pm accordingly
|
||||
a/p : use 12 hour clock and display a and p accordingly
|
||||
/ : insert date seperator
|
||||
: : insert time seperator
|
||||
"xx" : literal text
|
||||
'xx' : literal text
|
||||
}
|
||||
|
||||
// these constant strings will be changed to pchars too, someday :)
|
||||
ShortDateFormat:string='d/m/y';
|
||||
LongDateFormat:string='dd" "mmmm" "yyyy';
|
||||
ShortTimeFormat:string='hh:nn';
|
||||
LongTimeFormat:string='hh:nn:ss';
|
||||
|
||||
Eoln = #10; // or should that be #13, or $0d0a
|
||||
|
||||
type
|
||||
TSystemTime=record
|
||||
wYear:word;wMonth:word;wDay:word;
|
||||
wHour:word;wMinute:word;wSecond:word;wMilliSecond:word;
|
||||
end ;
|
||||
TDateTime = double;
|
||||
|
||||
{ Date and Time functions }
|
||||
|
||||
function DateToStr(Date:TDateTime):string;
|
||||
function TimeToStr(Time:TDateTime):string;
|
||||
function DateTimeToStr(DateTime:TDateTime):string;
|
||||
function EncodeDate(Year, Month, Day :word):TDateTime;
|
||||
function EncodeTime(Hour, Minute, Second, MilliSecond:word):TDateTime;
|
||||
procedure DecodeDate(Date:TDateTime;var Year:word;var Month:word;var Day:word);
|
||||
procedure DecodeTime(Time:TDateTime;var Hour:word;var Minute:word;var Second:word;var MilliSecond:word);
|
||||
function FormatDateTime(FormatStr:string;DateTime:TDateTime):string;
|
||||
function StrToDate(const s:string):TDateTime;
|
||||
function StrToTime(const s:string):TDateTime;
|
||||
function StrToDateTime(const s:string):TDateTime;
|
||||
function DayOfWeek(DateTime:TDateTime):longint;
|
||||
function Date:TDateTime;
|
||||
function Time:TDateTime;
|
||||
function Now:TDateTime;
|
||||
procedure GetLocalTime(var systemtime:tsystemtime);
|
||||
|
||||
|
||||
{
|
||||
|
||||
$Log$
|
||||
Revision 1.1 1998-04-10 15:17:46 michael
|
||||
+ Initial implementation; Donated by Gertjan Schouten
|
||||
His file was split into several files, to keep it a little bit structured.
|
||||
|
||||
|
||||
}
|
||||
106
rtl/objpas/fina.inc
Normal file
106
rtl/objpas/fina.inc
Normal file
@ -0,0 +1,106 @@
|
||||
{
|
||||
*********************************************************************
|
||||
$Id$
|
||||
Copyright (C) 1997, 1998 Gertjan Schouten
|
||||
|
||||
This program 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 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
*********************************************************************
|
||||
|
||||
System Utilities For Free Pascal
|
||||
}
|
||||
|
||||
|
||||
type
|
||||
PByte=^Byte;
|
||||
PWord=^Word;
|
||||
PLongint=^Longint;
|
||||
|
||||
const
|
||||
DayTable:array[Boolean,1..12] of longint =
|
||||
((0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334),
|
||||
(0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335));
|
||||
HexDigits: array[0..15] of char = '0123456789ABCDEF';
|
||||
|
||||
function ChangeFileExt(FileName, Extension: string): string;
|
||||
var i: longint;
|
||||
begin
|
||||
I := Length(FileName);
|
||||
while (I > 0) and not (FileName[I] in ['.', '\', ':']) do Dec(I);
|
||||
if (I = 0) or (FileName[I] <> '.') then I := 255;
|
||||
ChangeFileExt := Copy(FileName, 1, I - 1) + Extension;
|
||||
end;
|
||||
|
||||
function ExtractFilePath(FileName: string): string;
|
||||
var i: longint;
|
||||
begin
|
||||
i := Length(FileName);
|
||||
while (I > 0) and not (FileName[I] in ['\', ':']) do Dec(I);
|
||||
ExtractFilePath := Copy(FileName, 1, I);
|
||||
end;
|
||||
|
||||
function ExtractFileDir(FileName: string): string;
|
||||
var i: longint;
|
||||
begin
|
||||
I := Length(FileName);
|
||||
while (I > 0) and not (FileName[I] in ['\', ':']) do Dec(I);
|
||||
if (I > 1) and (FileName[I] = '\') and
|
||||
not (FileName[I - 1] in ['\', ':']) then Dec(I);
|
||||
ExtractFileDir := Copy(FileName, 1, I);
|
||||
end;
|
||||
|
||||
function ExtractFileDrive(FileName: string): string;
|
||||
var i, j: longint;
|
||||
begin
|
||||
if (Length(FileName) >= 3) and (FileName[2] = ':') then
|
||||
ExtractFileDrive := Copy(FileName, 1, 2)
|
||||
else if (Length(FileName) >= 2) and (FileName[1] = '\') and
|
||||
(FileName[2] = '\') then begin
|
||||
J := 0;
|
||||
I := 3;
|
||||
While (I < Length(FileName)) and (J < 2) do begin
|
||||
if FileName[I] = '\' then Inc(J);
|
||||
if J < 2 then Inc(I);
|
||||
end;
|
||||
if FileName[I] = '\' then Dec(I);
|
||||
ExtractFileDrive := Copy(FileName, 1, I);
|
||||
end else ExtractFileDrive := '';
|
||||
end;
|
||||
|
||||
function ExtractFileName(FileName: string): string;
|
||||
var i: longint;
|
||||
begin
|
||||
I := Length(FileName);
|
||||
while (I > 0) and not (FileName[I] in ['\', ':']) do Dec(I);
|
||||
ExtractFileName := Copy(FileName, I + 1, 255);
|
||||
end;
|
||||
|
||||
function ExtractFileExt(FileName: string): string;
|
||||
var i: longint;
|
||||
begin
|
||||
I := Length(FileName);
|
||||
while (I > 0) and not (FileName[I] in ['.', '\', ':']) do Dec(I);
|
||||
if (I > 0) and (FileName[I] = '.') then
|
||||
ExtractFileExt := Copy(FileName, I, 255)
|
||||
else ExtractFileExt := '';
|
||||
end;
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-04-10 15:17:46 michael
|
||||
+ Initial implementation; Donated by Gertjan Schouten
|
||||
His file was split into several files, to keep it a little bit structured.
|
||||
|
||||
}
|
||||
38
rtl/objpas/finah.inc
Normal file
38
rtl/objpas/finah.inc
Normal file
@ -0,0 +1,38 @@
|
||||
{
|
||||
*********************************************************************
|
||||
$Id$
|
||||
Copyright (C) 1997, 1998 Gertjan Schouten
|
||||
|
||||
This program 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 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
*********************************************************************
|
||||
|
||||
System Utilities For Free Pascal
|
||||
}
|
||||
|
||||
{ Filename Functions }
|
||||
|
||||
function ChangeFileExt(FileName, Extension: string): string;
|
||||
function ExtractFilePath(FileName: string): string;
|
||||
function ExtractFileDrive(FileName: string): string;
|
||||
function ExtractFileName(FileName: string): string;
|
||||
function ExtractFileExt(FileName: string): string; { Returns file extension like '.123' }
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-04-10 15:17:46 michael
|
||||
+ Initial implementation; Donated by Gertjan Schouten
|
||||
His file was split into several files, to keep it a little bit structured.
|
||||
|
||||
}
|
||||
288
rtl/objpas/syspch.inc
Normal file
288
rtl/objpas/syspch.inc
Normal file
@ -0,0 +1,288 @@
|
||||
{
|
||||
*********************************************************************
|
||||
$Id$
|
||||
Copyright (C) 1997, 1998 Gertjan Schouten
|
||||
|
||||
This program 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 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
*********************************************************************
|
||||
|
||||
System Utilities For Free Pascal
|
||||
}
|
||||
|
||||
{ PChar functions }
|
||||
|
||||
function NewStr(s:string):pchar;
|
||||
var p:pchar;l:longint;
|
||||
begin
|
||||
l := length(s);
|
||||
p := StrAlloc(l + 1);
|
||||
move(s[1], p^, l);
|
||||
byte(pchar(p + l)^) := 0;
|
||||
NewStr := p;
|
||||
end ;
|
||||
|
||||
function StrAlloc(Size:longint):pchar;
|
||||
var p:pointer;
|
||||
begin
|
||||
Getmem(p, size + sizeof(longint));
|
||||
Move(Size, p^, sizeof(longint));
|
||||
pbyte(p + sizeof(longint))^ := 0;
|
||||
StrAlloc := pchar(p + sizeof(longint));
|
||||
end ;
|
||||
|
||||
procedure StrDispose(var p:pchar);
|
||||
var l:longint;
|
||||
begin
|
||||
if (p = nil) then exit;
|
||||
p := pchar(p - sizeof(longint));
|
||||
move(p^, l, sizeof(longint));
|
||||
freemem(p, l + sizeof(longint));
|
||||
p := nil;
|
||||
end ;
|
||||
|
||||
function StrPas(p:pchar):string;
|
||||
begin
|
||||
asm
|
||||
movl P,%eax
|
||||
movl %eax,%esi
|
||||
movl __RESULT,%eax
|
||||
movl %eax,%edi
|
||||
pushl %edi
|
||||
incl %edi
|
||||
xorl %eax,%eax
|
||||
movw $255,%cx
|
||||
STR_LOOP1:
|
||||
lodsb
|
||||
orb %al,%al
|
||||
jz STR_END
|
||||
stosb
|
||||
loop STR_LOOP1
|
||||
STR_END:
|
||||
popl %edi
|
||||
movw $255,%ax
|
||||
subw %cx,%ax
|
||||
movb %al,(%edi)
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function StrLen(p:pchar):longint;
|
||||
begin
|
||||
asm
|
||||
movl p,%eax
|
||||
movl %eax,%esi
|
||||
xorl %eax,%eax
|
||||
movl $0xFFFFFFFF,%ecx
|
||||
STRLEN_LOOP:
|
||||
incl %ecx
|
||||
lodsb
|
||||
orb %al,%al
|
||||
jnz STRLEN_LOOP
|
||||
movl %ecx,__RESULT
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function StrEnd(p:pchar):pchar;
|
||||
begin
|
||||
asm
|
||||
movl p,%eax
|
||||
movl %eax,%esi
|
||||
STREND_LOOP:
|
||||
lodsb
|
||||
orb %al,%al
|
||||
jnz STREND_LOOP
|
||||
movl %esi,__RESULT
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function StrMove(Dest, Source: PChar; Count: longint): PChar;
|
||||
begin
|
||||
asm
|
||||
movl source,%eax
|
||||
movl %eax,%esi
|
||||
movl dest,%eax
|
||||
movl %eax,%edi
|
||||
movl %edi,__RESULT
|
||||
movl COUNT,%ecx
|
||||
movl %ecx,%edx
|
||||
cmpl %esi,%edi
|
||||
jg STRMOVE_BACK
|
||||
shrl $2,%ecx
|
||||
rep
|
||||
movsl
|
||||
movl %edx,%ecx
|
||||
andl $3,%ecx
|
||||
rep
|
||||
movsb
|
||||
jmp STRMOVE_END
|
||||
STRMOVE_BACK:
|
||||
addl %ecx,%edi
|
||||
decl %edi
|
||||
addl %ecx,%esi
|
||||
decl %esi
|
||||
andl $3,%ecx
|
||||
STD
|
||||
rep
|
||||
movsb
|
||||
subl $3,%esi
|
||||
subl $3,%edi
|
||||
movl %edx,%ecx
|
||||
shrl $2,%ecx
|
||||
rep
|
||||
movsl
|
||||
CLD
|
||||
STRMOVE_END:
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function StrCat(Dest, Source: PChar): PChar;
|
||||
begin
|
||||
StrCat := Dest;
|
||||
while char(dest^) <> #0 do
|
||||
dest := dest + 1;
|
||||
while char(source^) <> #0 do begin
|
||||
char(dest^) := char(source^);
|
||||
dest := dest + 1;
|
||||
source := source + 1;
|
||||
end ;
|
||||
char(dest^) := #0;
|
||||
end ;
|
||||
|
||||
function StrCat(Dest:pchar; Source: string): PChar;
|
||||
var l:longint;
|
||||
begin
|
||||
StrCat := Dest;
|
||||
while char(dest^) <> #0 do
|
||||
dest := dest + 1;
|
||||
l := length(source);
|
||||
move(source[1], dest^, l);
|
||||
dest := dest + l;
|
||||
char(dest^) := #0;
|
||||
end ;
|
||||
|
||||
function StrCat(var Dest:string; Source: pchar): String;
|
||||
var count,l:longint;
|
||||
begin
|
||||
l := length(Dest);
|
||||
count := setLength(Dest, l + StrLen(Source)) - l;
|
||||
if (count > 0) then
|
||||
move(source^, dest[l + 1], count);
|
||||
StrCat := Dest;
|
||||
end ;
|
||||
|
||||
function StrIns(Dest:pchar; Source: string): PChar;
|
||||
var len:longint;
|
||||
begin
|
||||
len := length(Source);
|
||||
StrMove(dest + len, dest, 1 + strlen(dest));
|
||||
Move(Source[1], dest^, len);
|
||||
StrIns := dest;
|
||||
end ;
|
||||
|
||||
function StrCopy(Dest, Source: PChar): Pchar;
|
||||
begin
|
||||
asm
|
||||
movl Dest,%eax
|
||||
movl %eax,%edi
|
||||
movl %eax,__RESULT
|
||||
movl Source,%eax
|
||||
movl %eax,%esi
|
||||
STRCOPY_LOOP:
|
||||
lodsb
|
||||
stosb
|
||||
orb %al,%al
|
||||
jnz STRCOPY_LOOP
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function StrLCopy(Dest, Source: PChar; MaxLen: longint): PChar;
|
||||
begin
|
||||
asm
|
||||
movl Dest,%eax
|
||||
movl %eax,__RESULT
|
||||
movl %eax,%edi
|
||||
movl Source,%eax
|
||||
movl %eax,%esi
|
||||
movl MaxLen,%ecx
|
||||
orl %ecx,%ecx
|
||||
jz STRLCOPY_END
|
||||
STRLCOPY_LOOP:
|
||||
lodsb
|
||||
orb %al,%al
|
||||
jz STRLCOPY_END
|
||||
stosb
|
||||
loop STRLCOPY_LOOP
|
||||
STRLCOPY_END:
|
||||
xorb %al,%al
|
||||
stosb
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function StrScan(str:pchar;ch:char):pchar;
|
||||
begin
|
||||
asm
|
||||
movl str,%eax
|
||||
movl %eax,%esi
|
||||
movb ch,%bl
|
||||
STRSCAN_LOOP:
|
||||
lodsb
|
||||
cmpb %al,%bl
|
||||
je STRSCAN_END
|
||||
orb %al,%al
|
||||
jnz STRSCAN_LOOP
|
||||
STRSCAN_END:
|
||||
decl %esi
|
||||
movl %esi,__RESULT
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function StrRScan(str:pchar;ch:char):pchar;
|
||||
begin
|
||||
asm
|
||||
movl str,%eax
|
||||
movl %eax,%esi
|
||||
movl %eax,%edx
|
||||
movb ch,%bl
|
||||
STRRSCAN_LOOP:
|
||||
lodsb
|
||||
cmpb %al,%bl
|
||||
jne STRRSCAN_NOTFOUND
|
||||
movl %esi,%edx
|
||||
decl %edx
|
||||
STRRSCAN_NOTFOUND:
|
||||
orb %al,%al
|
||||
jnz STRRSCAN_LOOP
|
||||
movl %edx,__RESULT
|
||||
end ;
|
||||
end ;
|
||||
|
||||
function StrTer(str:pchar;l:longint):pchar;
|
||||
begin
|
||||
asm
|
||||
movl str,%eax
|
||||
movl %eax,__RESULT
|
||||
addl l,%eax
|
||||
movl %eax,%edi
|
||||
xorb %al,%al
|
||||
movb %al,(%edi)
|
||||
end ;
|
||||
end ;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-04-10 15:17:46 michael
|
||||
+ Initial implementation; Donated by Gertjan Schouten
|
||||
His file was split into several files, to keep it a little bit structured.
|
||||
|
||||
}
|
||||
49
rtl/objpas/syspchh.inc
Normal file
49
rtl/objpas/syspchh.inc
Normal file
@ -0,0 +1,49 @@
|
||||
{
|
||||
*********************************************************************
|
||||
$Id$
|
||||
Copyright (C) 1997, 1998 Gertjan Schouten
|
||||
|
||||
This program 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 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
*********************************************************************
|
||||
|
||||
System Utilities For Free Pascal
|
||||
}
|
||||
|
||||
|
||||
function NewStr(s:string):pchar;
|
||||
function StrAlloc(Size:longint):pchar;
|
||||
procedure StrDispose(var p:pchar);
|
||||
function StrPas(p:pchar):string;
|
||||
function StrLen(p:pchar):longint;
|
||||
function StrEnd(p:pchar):pchar;
|
||||
function StrCat(Dest, Source:pchar): PChar;
|
||||
function StrCat(Dest:pchar; Source: string): PChar;
|
||||
function StrCat(var Dest:string; Source: pchar): String;
|
||||
function StrIns(Dest:pchar; Source: string): PChar;
|
||||
function StrMove(Dest, Source: PChar; Count: longint): PChar;
|
||||
function StrCopy(Dest, Source: PChar): Pchar;
|
||||
function StrLCopy(Dest, Source: PChar; MaxLen: longint): PChar;
|
||||
function StrScan(str:pchar;ch:char):PChar;
|
||||
function StrRScan(str:pchar;ch:char):PChar;
|
||||
function StrTer(str:pchar;l:longint):pchar;
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-04-10 15:17:46 michael
|
||||
+ Initial implementation; Donated by Gertjan Schouten
|
||||
His file was split into several files, to keep it a little bit structured.
|
||||
|
||||
}
|
||||
140
rtl/objpas/sysstr.inc
Normal file
140
rtl/objpas/sysstr.inc
Normal file
@ -0,0 +1,140 @@
|
||||
{
|
||||
*********************************************************************
|
||||
$Id$
|
||||
Copyright (C) 1997, 1998 Gertjan Schouten
|
||||
|
||||
This program 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 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
*********************************************************************
|
||||
|
||||
System Utilities For Free Pascal
|
||||
}
|
||||
|
||||
{ string manipulation functions }
|
||||
|
||||
function setLength(var s:string; newLength:longint):longint;
|
||||
begin
|
||||
if (newLength > 255) then
|
||||
newLength := 255;
|
||||
s[0] := char(newLength);
|
||||
setLength := ord(s[0]);
|
||||
end ;
|
||||
|
||||
function UpperCase(s: string): string;
|
||||
var l:longint;
|
||||
begin
|
||||
l := Length(S);
|
||||
while l <> 0 do begin
|
||||
if (s[l] in ['a'..'z']) then s[l] := char(byte(s[l]) - 32);
|
||||
dec(l);
|
||||
end;
|
||||
uppercase := s;
|
||||
end;
|
||||
|
||||
function LowerCase(s: string): string;
|
||||
var l:longint;
|
||||
begin
|
||||
l := Length(S);
|
||||
while l <> 0 do begin
|
||||
if (s[l] in ['A'..'Z']) then s[l] := char(byte(s[l]) + 32);
|
||||
dec(l);
|
||||
end;
|
||||
LowerCase := s;
|
||||
end;
|
||||
|
||||
{!$I ANSI.PPI}
|
||||
|
||||
function AnsiUpperCase(s: string):string;
|
||||
begin
|
||||
end ;
|
||||
|
||||
function AnsiLowerCase(s: string):string;
|
||||
begin
|
||||
end ;
|
||||
|
||||
function left(s: string;i:Longint): string;
|
||||
begin
|
||||
left := copy(s,1,i);
|
||||
end ;
|
||||
|
||||
function right(s: string;i:Longint): string;
|
||||
begin
|
||||
right := copy(s,1 + length(s)-i,i);
|
||||
end ;
|
||||
|
||||
function trim(s: string):string;
|
||||
var i,l:longint;
|
||||
begin
|
||||
l := length(s);
|
||||
while (s[l] = ' ') and (l > 0) do dec(l);
|
||||
setLength(s, l);
|
||||
i := 1;
|
||||
while (s[i] = ' ') and (i <= l) do inc(i);
|
||||
trim := copy(s, i, l);
|
||||
end ;
|
||||
|
||||
function trimleft(s:string):string;
|
||||
var i,l:longint;
|
||||
begin
|
||||
l := length(s);
|
||||
i := 1;
|
||||
while (s[i] = ' ') and (i <= l) do inc(i);
|
||||
trimleft := copy(s, i, l);
|
||||
end ;
|
||||
|
||||
function trimright(s:string):string;
|
||||
var l:longint;
|
||||
begin
|
||||
l := length(s);
|
||||
while (s[l] = ' ') and (l > 0) do dec(l);
|
||||
setLength(s, l);
|
||||
trimright := s;
|
||||
end ;
|
||||
|
||||
{ Conversion stuff }
|
||||
|
||||
function IntToStr(l:longint):string;
|
||||
var result:string;
|
||||
begin
|
||||
system.str(l,result);
|
||||
inttostr := result;
|
||||
end ;
|
||||
|
||||
function StrToInt(s:string):longint;
|
||||
var result:longint;c:word;
|
||||
begin
|
||||
val(s, result, c);
|
||||
strtoint := result;
|
||||
end ;
|
||||
|
||||
function IntToHex(Value: longint; Digits: longint): string;
|
||||
var result:string;i:longint;
|
||||
begin
|
||||
result := ' ';
|
||||
setLength(result, digits);
|
||||
for i := 0 to digits - 1 do begin
|
||||
result[digits - i] := HexDigits[value and 15];
|
||||
value := value shr 4;
|
||||
end ;
|
||||
inttohex := result;
|
||||
end ;
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-04-10 15:17:46 michael
|
||||
+ Initial implementation; Donated by Gertjan Schouten
|
||||
His file was split into several files, to keep it a little bit structured.
|
||||
|
||||
}
|
||||
49
rtl/objpas/sysstrh.inc
Normal file
49
rtl/objpas/sysstrh.inc
Normal file
@ -0,0 +1,49 @@
|
||||
{
|
||||
*********************************************************************
|
||||
$Id$
|
||||
Copyright (C) 1997, 1998 Gertjan Schouten
|
||||
|
||||
This program 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 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
*********************************************************************
|
||||
|
||||
System Utilities For Free Pascal
|
||||
}
|
||||
|
||||
{ String functions }
|
||||
|
||||
function setLength(var s: string; newLength: longint): longint;
|
||||
function UpperCase(s: string): string;
|
||||
function LowerCase(s: string): string;
|
||||
function AnsiUpperCase(s: string): string;
|
||||
function AnsiLowerCase(s: string): string;
|
||||
function Left(s: string; i: longint): string;
|
||||
function Right(s: string; i: longint): string;
|
||||
function Trim(s: string): string;
|
||||
function TrimLeft(s: string): string;
|
||||
function TrimRight(s: string): string;
|
||||
|
||||
{ Conversion Functions }
|
||||
|
||||
function IntToStr(l:longint):string;
|
||||
function StrToInt(s:string):longint;
|
||||
function IntToHex(Value: longint; Digits: longint): string;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-04-10 15:17:46 michael
|
||||
+ Initial implementation; Donated by Gertjan Schouten
|
||||
His file was split into several files, to keep it a little bit structured.
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user