Mega Code Archive
stringroutines
<![CDATA[
*************************************************************************************************************************
Useful string routines.
cleanstring is a nice one.
*************************************************************************************************************************
function cleanstring(var s:string):integer;//removes spaces and chars<#32 from beginning / end of string
//returns no. of chars removed
function space(i:integer):string; //returns a string consisting of <i> spaces
function repeatstr(str:string;count:integer):string; //returns a string consisting of <count> occurences of str
function removecr(s:string):string; //removes characters<#32 string replacing with spaces
function removedblspc(s:string):string; //replaces double spaces with single spaces
function propercase(s:string):string; //capitalises the first character of each word
function getnextword(var s:string):string; //returns first word in s (and removes it from s cf strtok in C)
function replace(src,from,tostr:string):string;//replaces occurrences of <from> in <src> with <tostr> src is
function rpos(const substr,str:string):integer;//finds *last* occurrence of substr in str returns 0 for none
function num8pad(i:integer):string; //Creates left padded string version of a number (8 chars)
//i.e. num8pad(123) == "00000123"
function strclean(p:pchar):integer; //pchar version of cleanstring;
procedure hrtout(p:pchar); //pchar version of removecr
function isnumeric(c:char):boolean; //
function isalphanumeric(c:char):boolean; //
function isalpha(c:char):boolean; //
function isuppercase(c:char):boolean; //
function islowercase(c:char):boolean; //
procedure mystrpcopy(p:pchar;s:string); // obsolete - retained for Delphi 1 compatibility - overcomes problem
// with delphi 2 strpcopy which only converted first 255 char even
// when using long strings.
function strlpas(p:pchar;count:integer):string; //same as strpas but you only get <count> chars
function strlchr(p:pchar;c:char;count:integer):pchar; //same as strchr but in first <count> chars;
function delsgmltags(const s:string):string;//removes sgml tags (does nothing with entities)
function removetrailingslash(const s:string):string; //removes trailing slashes and backslashes from a directoryname
function removefileextension(const s:string):string; //removes everything after the last dot in a filename
function HEX_INT(c:char):integer; //converts ['0'..'9','a'..'f','A'..'F'] into an integer 0-15
function INT_HEX(i:integer):char; //converts 0->15 to '0'..'9','A'..'F' with implicit modulo
function URLDecode(s:string):string; //converts a browser-mangled string to a clear string
//i.e. 'Dom%27s%20code%20is%20slow%21' -> 'Dom''s code is slow'
function URLEncode(s:string):string; //opposite of the above
procedure fWriteLn(f:TStream;s:string);
function Normalisedcp(cpin:string;maxcplen:integer):string;//will check a westlaw cp with spaces removed does not exceed maxlen characters. If it has then
//then characters are removed from the cp until it reaches its maximum normalised length.
Function PadStr(Num: Integer; LR, ch, s: String): String ; //pads a string to num characters on the left L or right R with character ch
Function YYYYMMDDTODateTime(s:String):TDateTime;
implementation
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<-----=======----->>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
Function PadStr(Num: Integer; LR, ch, s: String): String ;
var len,x:integer;
Begin
//If s='' Then Exit ;
Result:=s ;
len:=length(s);
If len>=Num Then Exit ;
LR:=UpperCase(LR) ;
for x:=(len+1) to Num do
Begin
If LR='L' then Result:=ch+Result
Else Result:=Result+Ch ;
End ; // for
End ; // Function
function Normalisedcp(cpin:string;maxcplen:integer):string;
{will check a cp when it has had spaces removed does not exceed maxlen characters. If it has then
then characters are removed from the cp until it reaches its maximum normalised length.}
var
x,ct,lastspace:integer;
done:boolean;
begin
if length(replace(cpin,' ',''))>maxcplen then
begin
x:=0;
ct:=0;
lastspace:=1;
done:=false;
while (not done) and (x<=maxcplen) do
begin
if cpin[x]<>' ' then
begin
inc(ct);
if ct=maxcplen then
done:=true;
end
else
lastspace:=x;
inc(x);
end;
result:=copy(cpin,1,lastspace-1);
end
else
result:=cpin;
end;
procedure fWriteLn(f:TStream;s:string);
const crlf:pchar = #13#10;
begin
if s<>'' then
f.write(s[1],length(s));
f.write(crlf[0],2);
end;
function INT_HEX(i:integer):char;
const hexchars:pchar ='0123456789ABCDEF';
begin
result:=hexchars[i and $F];
end;
function URLEncode(s:string):string;
var i,j,l:integer;
begin
if s='' then
begin
result:='';
exit;
end;
l:=0;
//calculate length of resultant string
for i:=1 to length(s) do
begin
if not(s[i] in ['0'..'9','a'..'z','A'..'Z']) then
inc(l,3)
else
inc(l,1);
end;
setlength(result,l);
j:=1;
for i:=1 to length(s) do
begin
if not(s[i] in ['0'..'9','a'..'z','A'..'Z']) then
begin
result[j]:='%';
result[j+1]:=INT_HEX(ord(s[i]) shr 4);
result[j+2]:=INT_HEX(ord(s[i]));
inc(j,3);
end
else
begin
result[j]:=s[i];
inc(j);
end;
end;
end;
function URLDecode(s:string):string;
var i,j,k:integer;
begin
i:=1;
j:=1;
setlength(result,length(s)); //result will be at least as long as encoded string
while i<=length(s) do
begin
if (s[i]='%') and (length(s)>=i+2) then //two char code
begin
k:=HEX_INT(s[i+2])+16*HEX_INT(s[i+1]);
result[j]:=chr(k);
inc(j);
inc(i,3);
end
else
begin
result[j]:=s[i];
inc(j);
inc(i);
end;
end;
SetLength(result,j-1); //reset string to correct length;
end;
function HEX_INT(c:char):integer;
begin
if c in ['0'..'9'] then
result:=ord(c)-ord('0')
else if c in ['A'..'F'] then
result:=10+ord(c)-ord('A')
else if c in ['a'..'f'] then
result:=10+ord(c)-ord('a')
else
result:=0;
end;
function removefileextension(const s:string):string;
var i,j:integer;
begin
result:=s;
i:=rpos('.',result);
j:=rpos('\',result);
if (i>j) then
setlength(result,i-1);
end;
function removetrailingslash(const s:string):string;
begin
result:=s;
while (result<>'') and ((result[length(result)]='\') or (result[length(result)]='/')) do result:=copy(result,1,length(result)-1);
end;
function num8pad(i:integer):string;
var s:string;
begin
s:=inttostr(i);
result:=copy('00000000'+s,1+length(s),8);
end;
function rpos(const substr,str:string):integer;
var i:integer;
begin
result:=0;
if (substr='') then exit;
for i:=length(str) downto 1 do
begin
if (str[i]=substr[1]) then
begin
if (copy(str,i,length(substr))=substr) then
begin
result:=i;
exit;
end;
end;
end;
end;
function strlchr(p:pchar;c:char;count:integer):pchar;
var q:pchar;
begin
result:=nil;
q:=p+count;
while (p<q) do
begin
if (p^=c) then
begin
result:=p;
exit;
end;
inc(p);
end;
end;
procedure mystrpcopy(p:pchar;s:string);
begin
if s='' then
p[0]:=chr(0)
else
StrCopy(p,@s[1]);
end;
function strlpas(p:pchar;count:integer):string;
//var s:string;
var i:integer;
begin
{s:='';
i:=0;
while (i<count) and (p[i]<>chr(0)) do
begin
s:=s+p[i];
inc(i);
end;}
if count<=0 then
begin
result:='';
exit;
end;
asm
push edi
push ecx
mov edi,p
mov ecx,count
cld
mov al,0
REPNE SCASB
JNE @skipback
inc cx;
@skipback:
mov EAX,count
sub eax,ecx
mov i,eax
pop ecx
pop edi
end;
setlength(result,i);
if i>0 then
begin
strmove(@result[1],p,i);
end;
//s:=copy(string(p),1,count);
//strlpas:=s;
end;
procedure hrtout(p:pchar);
var q:pchar;
begin
strclean(p);
repeat
q:=strscan(p,chr(13));
if (q=nil) then q:=strscan(p,chr(10));
if (q<>nil) then
begin
if (q=p) then
strclean(p)
else
begin
dec(q);
if q[0]=' ' then
strclean(q+1)
else
begin
q[1]:=' ';
strclean(q+2);
end;
end;
end;
until (q=nil);
end;
function isnumeric(c:char):boolean;
begin
if (c>='0') and (c<='9') then isnumeric:=true else isnumeric:=false;
end;
function isalpha(c:char):boolean;
begin
isalpha:=isuppercase(c) or islowercase(c);
end;
function isalphanumeric(c:char):boolean;
begin
isalphanumeric:=isalpha(c) or isnumeric(c);
end;
function isuppercase(c:char):boolean;
begin
if (c>='A') and (c<='Z') then isuppercase:=true else isuppercase:=false;
end;
function islowercase(c:char):boolean;
begin
if (c>='a') and (c<='z') then islowercase:=true else islowercase:=false;
end;
function strclean(p:pchar):integer;
var q:pchar;
i:integer;
begin
i:=0;
while (p[0]<>chr(0)) and (p[0]<=chr(32)) do
begin
q:=p;
while (q[0]<>chr(0)) do
begin
q[0]:=q[1]; q:=q+1;
inc(i);
end;
end;
q:=strend(p);
while (q>=p) and (q[0]<=chr(32)) do
begin
q[0]:=chr(0);
q:=q-1;
inc(i);
end;
strclean:=i;
end;
function cleanstring(var s:string):integer;
var i:integer;
begin
i:=0;
while (length(s)>0) and (ord(s[1])<=32) do begin s:=copy(s,2,MaxInt);inc(i);end;
while (length(s)>0) and (ord(s[length(s)])<=32) do begin s:=copy(s,1,length(s)-1);inc(i);end;
cleanstring:=i;
end;
function space(i:integer):string;
var s:string;
j:integer;
begin
setlength(s,i);
for j:=1 to i do s[j]:=' ';
space:=s;
end;
function repeatstr(str:string;count:integer):string;
var x:integer;
begin
result:='';
for x:=1 to count do
result:=result+str;
end;
function removecr(s:string):string;
var s2:string;
i:integer;
begin
s2:='';
i:=1;
while (i<=length(s)) do
begin
if s[i]>=chr(32) then s2:=s2+s[i] else s2:=s2+' ';
inc(i);
end;
removecr:=s2;
end;
function removedblspc(s:string):string;
var s2:string;
i:integer;
lastspc:boolean;
begin
{convert chars<32 to space}
i:=1;
while (i<length(s)) do
begin
if (s[i]<chr(32)) then s[i]:=' ';
inc(i);
end;
lastspc:=false;
s2:='';
i:=1;
while (i<=length(s)) do
begin
if (s[i]=' ') then
begin
if not(lastspc) then s2:=s2+' ';
lastspc:=true;
end
else
begin
s2:=s2+s[i];
lastspc:=false;
end;
inc(i);
end;
removedblspc:=s2;
end;
function getnextword(var s:string):string;
var w:string;
i:integer;
begin
i:=pos(' ',s);
if (i>0) then
begin
w:=copy(s,1,i-1);
s:=copy(s,i+1,MAXINT);
end
else
begin
w:=s;
s:='';
end;
getnextword:=w;
end;
function propercase(s:string):string;
var w,s2:string;
begin
s2:='';
repeat
w:=getnextword(s);
if (w<>'') then
begin
w:=lowercase(w);
if (w<>'of') and (w<>'and') and (w<>'in') and (w<>'the') then
w[1]:=uppercase(w[1])[1];
if (s2<>'') then s2:=s2+' ';
s2:=s2+w;
end;
until s='';
if (length(s2)>0) then s2[1]:=(uppercase(s2[1]))[1];
propercase:=s2;
end;
function replace(src,from,tostr:string):string;
var ss:string;
i,fromlen:integer;
begin
ss:='';
fromlen:=length(from);
repeat
i:=pos(from,src);
if (i>0) then
begin
ss:=ss+copy(src,1,i-1)+tostr;
src:=copy(src,i+fromlen,maxint);
end
else
begin
ss:=ss+src;
src:='';
end;
until src='';
replace:=ss;
end;
function delsgmltags(const s:string):string;
//removes <section> </section> type tags from a string
var s2:string;
i,j:integer;
begin
i:=pos('<',s);
j:=pos('>',s);
s2:=s;
while (i>0) and (j>0) and (j>i) do
begin
s2:=copy(s2,1,i-1)+copy(s2,j+1,maxint);
i:=pos('<',s2);
j:=pos('>',s2);
end;
delsgmltags:=s2;
end;
Function YYYYMMDDTODateTime(s:String):TDateTime;
procedure barf;
begin
raise EConvertError.Create('Invalid date format should be of the form YYYY-MM-DD');
end;
var y,m,d:word;
begin
y:=0;
m:=0;
d:=0;
if length(s)<>10 then barf;
if (s[5]<>'-') or (s[8]<>'-') then barf;
try
y:=strtoint(copy(s,1,4));
m:=strtoint(copy(s,6,2));
d:=strtoint(copy(s,9,2));
except
on e:Exception do barf;
end;
result:=EncodeDate(y,m,d);
end;
end.
*************************************************************************************************************************
Gary Wilson.
Product Manager - EMIS Legal
Work Email: GaryWilson@emis-support.demon.co.uk <mailto:GaryWilson@emis-support.demon.co.uk>
Home Email: willyat6@garysown.freeserve.co.uk <mailto:willyat6@garysown.freeserve.co.uk>
Reply always!
"Privileged and/or Confidential information may be contained in this message. If you are not the original addressee indicated in this message (or responsible for delivery of the message to such person), you may not copy or deliver this message to anyone. In such case, please delete this message, and notify us immediately. Opinions, conclusions and other information expressed in this message are not given or endorsed by my firm or employer unless otherwise indicated by an authorised representative independently of this message."
Egton Medical Information Systems Limited.
Registered in England. No 2117205. Registered Office:
Park House Mews, 77 Back Lane, Off Broadway,
Horsforth, Leeds, LS18 4RF
]]>