Contributor: TOBIN FRICKE
Program Sig;
{ Description: This is a little program which I wrote whose sole purpose }
{ in life is to add signature lines to messages written in }
{ an offline mail reader. The program scans a text file for}
{ instances of /SIGx (where x is a number) and replaces them}
{ with signature number x from a configuration file. }
{ Requires: USEFULL.PAS written by me. Email me if you don't have it.}
{ ACOLOR.INC written by me. Email me if you don't have it.}
{ NOTE : they are Attached at the end of this unit }
{ Created: March 1995 }
{ Author: Tobin Fricke (tobin@mail.edm.net) }
{ If you use this, I'd appreciate it if you could send me a postcard }
{ from where you live, or at least send me an email. My email address }
{ is tobin@mail.edm.net. If that doesn't work, try using }
{ fricke@roboben.engr.ucdavis.edu. My postal address is: }
{ 25001 El Cortijo Ln., Mission Viejo, CA 92691-5236, USA. Thanks! }
{
; CyberSig configuration file example:
@1
レトトトトトトトトトトトソ
ウ Light Ray ウ
タトトトトトトトトトトトル
@2
Tobin T. Fricke
TobinTech Engineering
dr261@cleveland.freenet.edu
}
Uses CRT, Usefull;
Const MyVersion='1.00';
{$I ACOLOR.INC}
Procedure Process(Config,Filename:String);
Const ConfigF=0; InputF=1; OutputF=2;
Var F:Array[0..2] of Text;
N,S,W,Q:String;
B:Byte;
Rep:Boolean;
begin
Assign(F[ConfigF],Config);
Assign(F[InputF],Filename);
N:=TempFile('');
Rename(F[InputF],N);
Reset(F[InputF]);
Assign(F[OutputF],Filename);
Rewrite(F[OutputF]);
Repeat
Readln(F[InputF],S);
If Pos('/SIG',UPSTRING(S))=1
then
begin
Write(' `B?`3 Found '+S);
Rep:=False;
Reset(F[ConfigF]);
B:=0;
Repeat
Readln(F[ConfigF],W);
If W[1]';' then
begin
If W[1]='@' then B:=Val(del(W,1,1))
else
begin
Q:=UpString('/SIG'+Str(B));
if Q=UpString(S) then
begin
System.Writeln(F[OutputF],W);
Rep:=True;
end;
end;
end;
Until EOF(F[ConfigF]);
If Rep then Writeln(', Replaced with signature') else
Writeln(', Signature not found in config file');
Close(F[ConfigF]);
end
else
System.Writeln(F[OutputF],S);
Until EOF(F[InputF]);
Close(F[InputF]);
Close(F[OutputF]);
Erase(F[InputF]);
Rename(F[OutputF],Filename);
end;
Begin
clrScr;
Writeln(' `4Cy`Cbe`FrSig Signature App`Cli`4er`8,`7 Version `F'+MyVersion+'`7');
Writeln(' `9Copyright `1(`9C`1)`9 1995 by Tobin T`1.`9 Fricke`1,`9 All Rights Reserved`1.`7 ');
Writeln(' `3Created At the `2Di`AGi`FTAL Fo`ARE`2ST `3(`B714`3)`B 586`3-`B6142 `928800`1bps`7');
If (ParamCount2) or
(Not FileExists(ParamStr(1))) or
(Not FileExists(ParamStr(2)))
then
begin
Writeln(' `EUSAGE: `F'+ParamStr(0)+' `8(`7CONFIG FILE`8) (`7FILENAME`8)`7');
Writeln(' `8(`7CONFIG FILE`8) `3is the complete path and filename of your config file. ');
Writeln(' `8(`7FILENAME`8) `3is the complete path and filename of the message file to process. ');
If ParamCount=2 then
begin
If Not FileExists(ParamStr(1)) then Writeln(' `B Cannot find '+paramStr(1));
If Not FileExists(ParamStr(2)) then Writeln(' `B Cannot find '+paramStr(2));
end;
end;
Process(ParamStr(1),ParamStr(2));
End.
{ ------------------- ACOLOR.INC ... CUT ---------}
{ Description: These routines allow one to embed color codes into strings }
{ and have them print out nicely. The format is ` followed }
{ by a character from 0 to 9, A to O, X or Y which represents}
{ the color. }
{ Filename: ACOLOR.INC }
{ Date: March 1995 }
{ Author: Tobin Fricke }
{ If you use this, I'd appreciate it if you could send me a postcard }
{ from where you live, or at least send me an email. My email address }
{ is tobin@mail.edm.net. If that doesn't work, try using }
{ fricke@roboben.engr.ucdavis.edu. My postal address is: }
{ 25001 El Cortijo Ln., Mission Viejo, CA 92691-5236, USA. Thanks! }
Procedure Write(S:String);
begin
Repeat
If S[1]='`' then
begin
S[2]:=UpCase(S[2]);
If S[2] IN ['0'..'9','A'..'O','X','Y'] then
Begin
If S[2] IN ['0'..'9'] then TextColor(Ord(S[2])-48);
IF S[2] IN ['A'..'F'] then TextColor(Ord(S[2])-55);
IF S[2] IN ['G'..'O'] then TextBackground(Ord(S[2])-71);
IF S[2]='X' then if (TextAttr AND 128)=0 then TextAttr:=TextAttr+128;
IF S[2]='Y' then if (TextAttr AND 128)=128 then TextAttr:=TextAttr-128;
Delete(S,1,2);
End;
end
else
begin
System.Write(S[1]);
Delete(S,1,1);
end;
Until S='';
end;
Procedure Writeln(S:String);
begin
Write(S+#10+#13);
end;
Function RandomCase(S:String):String;
Var B:Byte;
begin
For B:=1 to Length(S) do
if random>0.5 then S[B]:=LoCase(S[B]) else S[B]:=UpCase(S[B]);
RandomCase:=S;
end;
Function RandomColor(S:String):String;
var B:Byte;
begin
For B:=Length(S) downto 1 do
if Random>0.5 then Insert('`3',S,B) else Insert('`B',S,B);
RandomColor:=S;
end;
Function RainBow(S:String;A:Byte):String;
Begin
If A 0 do
begin
Remainder := Number mod BaseZ;
Number := Number div BaseZ;
case Remainder of
0..9: BaseZNumber := Char (Remainder + Ord ('0')) + BaseZNumber;
10..36: BaseZNumber := Char (Remainder - 10 + Ord ('A')) + BaseZNumber;
end;
end; end;
Procedure SwapStr(Var A,B:String);
var C:String;
begin
C:=A;
A:=B;
B:=C;
end;
{$IFDEF XXX}
Type Registers = record
case Integer of
0: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Word);
1: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
end;
{$ENDIF}
{$IFNDEF OS2}
FUNCTION NetworkDrive (Drive:CHAR):BOOLEAN;
{$Ifdef windows} var reg:Tregisters; {$else} var Reg:Registers; {$endif}
var DosErrorCode:Word;
BEGIN
Drive := UpCase (Drive); { Drive _must_ be 'A'..'Z' }
IF (Drive IN ['A'..'Z']) THEN BEGIN { make sure of 'A'..'Z' }
Reg.BL := ORD(Drive) - 64; { 1 = A:, 2 = B:, 3 = C: etc. }
Reg.AX := 4409ドル; { Dos fn: check if dev remote }
MsDos (Reg); { call Dos' services }
IF ODD(Reg.FLAGS) THEN { Dos reports function error? }
DosErrorCode := Reg.AX { yes: return Dos' error code }
ELSE BEGIN { else ... }
DosErrorCode := 0; { 0 = no error was detected }
IF ODD(Reg.DX SHR 12) THEN { is Drive remote? }
NetworkDrive := TRUE { yes: return TRUE }
ELSE
NetworkDrive := FALSE; { no: return FALSE }
{END IF ODD(Reg.DX...}
END; {IF ODD(Reg.FLAGS)}
END; {IF Drive}
END {NetworkDrive};
{$ENDIF}
Function SizeofFile(S:String):LongInt;
var F:File;
begin
Assign(F,S);
FileMode:=0;
Reset(F,1);
SizeOfFile:=FileSize(F);
Close(F);
end;
Function ActualFileSize:LongInt;
var F:File;
begin
ActualFileSize:=SizeOfFile(ParamStr(0));
end;
Procedure Lines50; Assembler;
ASM
MOV AH, 11H
MOV AL, 12H
MOV BL, 0
INT 10H
END;
Procedure Lines25; Assembler;
ASM
MOV AH, 11H
MOV AL, 14H
MOV BL, 0
INT 10H
END;
Procedure Lines35; Assembler;
ASM
MOV AH, 11H
MOV AL, 11H
MOV BL, 0
INT 10H
END;
Procedure Lines(S:String);
Begin
If Val(S)=50 then Lines50;
If Val(S)=25 then Lines25;
If Val(S)=35 then Lines35;
End;
Function Strip_(S:String):String;
var B:Byte;
begin
For B:=1 to length(S) do if S[B]='_' then S[B]:=' ';
Strip_:=S;
end;
Function Del(S:String; Index:Integer; Count:Integer):String;
begin
Delete(S,Index,Count);
Del:=S;
end;
Function WhatDir:String;
var s:String;
begin
GetDir(0,s);
whatdir:=s;
end;
Function Str(X:integer):String;
var S:String;
Begin
System.Str(X,S);
Str:=S;
End;
Function StrL(X:LongInt):String;
var S:String;
Begin
System.Str(X,S);
StrL:=S;
End;
Function StrW(X:word):String;
var S:String;
Begin
System.Str(X,S);
StrW:=S;
End;
Function StrR(X:Real):String;
var S:String;
Begin
System.Str(X,S);
StrR:=S;
End;
Function Val(S:String):Integer;
var A,B:Integer;
begin
System.Val(S,A,B);
If B=0 then Val:=A else begin Val:=0; UError:=B; End;
end;
Function ValW(S:String):Word;
var B:Integer;
A:Word;
begin
System.Val(S,A,B);
If B=0 then ValW:=A else begin ValW:=0; UError:=B; End;
end;
Function ValL(S:String):longint;
var B:integer;
A:longint;
begin
System.Val(S,A,B);
If B=0 then Vall:=A else begin Vall:=0; UError:=B; End;
end;
Function Upstring(S:String):String;
var
I:Byte;
begin
for i := 1 to Length(s) do s[i] := UpCase(s[i]);
Upstring:=S;
end;
Function LoCase(C:Char):Char;
begin
If (Ord(C)>64) and (Ord(C)<91) then LoCase:=Char(Ord(C)+32) else LoCase:=C; end; Function LoString(S:String):String; var I:Byte; begin for i := 1 to Length(s) do s[i] := LoCase(s[i]); Lostring:=S; end; Function NameCaps(S:String):String; var I:byte; begin S:=LoString(S); S[1]:=UpCase(S[1]); For I:=1 to Length(S) do If S[I]=' ' then if I '');
end; { FileExists }
Function Center(S:String; B:Byte):String;
var A:Byte;
Begin
Repeat
A:=Length(S) div 2;
If A<(b Div 2) then S:=' '+S+' '; Until (Length(S) div 2)>=((B) Div 2);
If Length(S)=((B));
While Length(S)>B do Delete(S,Length(S),1);
Left:=S;
End;
Function PadRight(S:String; B:Byte; C:Char):String;
var A:Byte;
Begin
Repeat
A:=Length(S);
If A=(B));
PadRight:=S;
End;
Function Right(S:String; B:Byte):String;
Begin
Right:=PadRight(S,B,' ');
End;
Function Rep(S:String; C:Word):String;
var W:Word;
T:String;
begin
T:='';
For W:=1 to C do T:=T+S;
Rep:=T;
end;
Function StrBool(S:String):Boolean;
begin
S:=UpString(S);
StrBool:=(Pos('T',S)>0);
end;
FUNCTION TempFile( Path: STRING ): STRING;
VAR
{$IFDEF WINDOWS}
DateStr : TDateTime;
{$ELSE}
DateStr : DateTime;
{$ENDIF}
Trash : WORD;
Time : LONGINT;
FileName : STRING;
Begin
If (Path'') AND (Path[length(Path)]'\') Then Path := Path + '\';
Repeat
With DateStr Do
Begin
GETDATE( Year, Month, Day, Trash );
GETTIME( Hour, Min, Sec, Trash );
End;
PackTime( DateStr, Time );
{$R-,Q-}
System.Str(Time,Filename);
FileName := Copy(Filename,1,8);
FileName := Filename+'.$$$';
{$R+,Q+}
Until Not FileExists(Path + FileName);
TempFile := Path + FileName;
END;
Function WordWrap(S:String; Var Remainder:String; Len:Byte):String;
Var W:String;
I:Integer;
begin
If S[1]=' ' then delete(S,1,1);
If Length(S)<=len then
begin
WordWrap:=S;
Remainder:='';
Exit;
end;
For I:=Len downto 1 do
begin
If S[I]=' ' then
begin
WordWrap:=Copy(S,1,I);
Remainder:=Copy(S,I,Length(S)-I+1);
Exit;
end;
end;
end;
Function AN(S:String):String;
begin
While S[1]=' ' do delete(S,1,1);
If UPCASE(S[1]) IN ['A','E','I','O','U'] THEN INSERT('an ',S,1) ELSE
INSERT('a ',S,1);
AN:=S;
end;
Function LastDrive: Char; Assembler;
Asm
mov ah, 19h
int 21h
push ax { save default drive }
mov ah, 0Eh
mov dl, 19h
int 21h
mov cl, al
dec cx
@@CheckDrive:
mov ah, 0Eh { check if drive valid }
mov dl, cl
int 21h
mov ah, 19h
int 21h
cmp cl, al
je @@Valid
dec cl { check next lovest drive number }
jmp @@CheckDrive
@@Valid:
pop ax
mov dl, al
mov ah, 0Eh
int 21h { restore default drive }
mov al, cl
add al, 'A'
end;
Function LongToHex(L:Longint):String;
var S:string;
begin
ConvertBase(10,StrL(L),16,S);
LongToHex:=S;
end;
End.