home *** CD-ROM | disk | FTP | other *** search
- (*#module(turbo_comp=>off)*)
- Program TICKET(Input,Output) ;
-
- (*
- Ticket Version 1.20 OS/2 Release 1
- Copyright 1989 - Paul J. West All Rights Reserved
- OS/2 mods Copyright 1992 - Charles L. Renshaw, All Rights Reserved
- Compiled With JPI TopSpeed Pascal for OS/2
- *)
-
- {$V-}
-
- IMPORT
- OS2DEF(ULONG),
- DOS(FILEFINDBUF,HDIR,HDIR_SYSTEM,HDIR_CREATE,EXIT_PROCESS),
- PASDOS(paramcount,paramstr,getdate,gettime),
- { TURBODOS,}
- Utility *,
- FidoNet *,
- TPDate *,
- TURBOSYS(_BLOCKWRITE)
- ;
-
- Const
- Version = 'V1.20.OS2.R1' ;
- MaxNodes = 128 ;
- MaxArea = 256 ;
-
- Var
- LogFile : text ;
- InboundDir : maxString;
- Directory : maxString;
- LogFileName : maxString ;
- Subject : String[71] ;
- ToUser : String[35] ;
- FromUser : String[35] ;
- FileCnt : Word ;
- Zone : Word ;
- Net : Word ;
- Node : Word ;
- Point : Word ;
- ToZone : Word ;
- ToNet : Word ;
- ToNode : Word ;
- ToPoint : Word ;
- Private : Boolean ;
- KillSent : Boolean ;
- ZoneGate : Boolean ;
- NodeCnt : Word ;
- AreaCnt : Word ;
- Idx : Word ;
- MsgHdr : FidoMessageHeader ;
- MsgFile : file of char ;
- NodeList : Array[1..MaxNodes] of FidoNet_Address ;
- AreaList : Array[1..MaxArea] of String[32] ;
- tstr : maxstring;
- ztstr : array[1..255] of char;
- attr : WORD;
- hndldir : HDIR;
- reslng, cnt, retn : WORD;
- rsrvd : ULONG;
- DirInfo : FILEFINDBUF ;
- TimeDate : integer ;
- TimeRec : DateTime ;
- fsize : ULONG;
-
- Procedure GetFileDTTM(fnam : maxstring; VAR fsz : ULONG; VAR dt : datetime);
-
- var
- Xthetime : integer;
- Xdt : datetime;
- Xtstr : maxstring;
- Xztstr : array[1..255] of char;
- Xattr : WORD;
- Xhndldir : HDIR;
- Xreslng, Xcnt, Xretn : WORD;
- Xrsrvd : ULONG;
- XDirInfo : FILEFINDBUF ;
-
- begin
- dt.year := 0;
- fsz := 0;
- Xtstr := fnam;
- StrToZ(Xtstr,Xztstr);
- Xattr := 0;
- Xhndldir := HDIR_CREATE;
- Xcnt := 1;
- Xreslng := size(XDirInfo);
- Xrsrvd := 0;
- Xretn := 0;
- Xretn := dos.FindFirst(Xztstr,Xhndldir,Xattr,
- XDirInfo,Xreslng,Xcnt,Xrsrvd) ;
- if Xretn = 0 then Begin
- Xthetime := XDirinfo.fdateLastWrite;
- Xthetime := Xthetime << 16;
- Xthetime := Xthetime + XDirInfo.ftimeLastWrite;
- unpacktime(Xthetime, Xdt);
- Xdt.year := Xdt.year + 80;
- fsz := XdirInfo.fileSize;
- dt := Xdt;
- end;
- end;
-
- Procedure Copyright ;
-
- Var
- Compiled : DateTime ;
-
- Begin
- UnPackTime(CompileTime,Compiled) ;
- WriteLn(Output,'TICKET ',Version,' - File Announcement Program') ;
- WriteLn(Output,'Copyright 1989 - Paul J. West All Rights Reserved') ;
- WriteLn(Output,'OS/2 Mods Copyright 1992 - Charles L. Renshaw, All Rights Reserved') ;
- WriteLn(Output,'Compiled ',
- Date_DMA(Compiled.Month),' ',Compiled.Day,', ',Compiled.Year+1980,' at ',
- PadRight(Word_To_Str(Compiled.Hour),2,'0'),':',
- PadRight(Word_To_Str(Compiled.Min) ,2,'0'),':',
- PadRight(Word_To_Str(Compiled.Sec) ,2,'0')) ;
- WriteLn(Output,'') ;
- End ;
-
- Procedure ReadPlease(KeyWord : MAXSTRING) ;
-
- Var
- PleaseFile : Text ;
- Line : MAXSTRING ;
- Tmp : MAXSTRING ;
- Found : Boolean ;
- Max : Word ;
- Idx : Word ;
-
- Begin
- {$I-}
- IOCheck := FALSE;
- Assign(PleaseFile,'PLEASE.ALL') ;
- Reset(PleaseFile) ;
- {$I+}
- IOCheck := TRUE;
- If IOresult <> 0 Then Begin
- WriteLn(Output,'Unable to find PLEASE.ALL') ;
- dos.exit(EXIT_PROCESS,1);
- End ;
-
- { Search For PLEASE Keyword }
-
- KeyWord := UpperCase(KeyWord) ;
- Found := False ;
- While (Not Eof(PleaseFile)) And (Not Found) Do Begin
- ReadLn(PleaseFile,Line) ;
- Line := UpperCase(Trim(Change(Line,chr(9),chr(32)))) ;
- If Field(Line,' ',1) = KeyWord Then
- Found := True ;
- End ;
-
- If Not Found Then Begin
- WriteLn(Output,'The Keyword ',KeyWord,' Was not found in PLEASE.ALL') ;
- dos.exit(EXIT_PROCESS,1);
- End ;
-
- { Process Nodes Listed }
-
- While (Not Eof(PleaseFile)) And Found Do Begin
- ReadLn(PleaseFile,Line) ;
- Line := Trim(Change(Line,chr(9),chr(32))) ;
- Max := DCount(Line,' ') ;
- If Max > 0 Then Begin
- For Idx := 1 To Max Do Begin
- Tmp := Field(Line,' ',Idx) ;
- If Tmp = '.' Then Begin
- Found := False ;
- End Else Begin
- NodeCnt := NodeCnt + 1 ;
- If NodeCnt > MaxNodes Then Begin
- WriteLn(Output,'To Many Nodes Specified - Maximum is ',MaxNodes) ;
- dos.exit(EXIT_PROCESS,1);
- End ;
- Fido_Address(Field(Line,' ',Idx)
- ,NodeList[NodeCnt].Zone
- ,NodeList[NodeCnt].Net
- ,NodeList[NodeCnt].Node
- ,NodeList[NodeCnt].Point) ;
- End ;
- End ;
- End ;
- End ;
- Close(PleaseFile) ;
- End ;
-
- Procedure ReadConfig ;
-
- Var
- ConfigFile : Text ;
- Line : MAXSTRING ;
- KeyWord : MAXSTRING ;
-
- Begin
- {$I-}
- IOCheck := FALSE;
- Assign(ConfigFile, 'TIC.CFG') ;
- Reset(ConfigFile) ;
- {$I+}
- IOCheck := TRUE;
- If IOresult <> 0 Then Begin
- WriteLn(Output,'Unable to open TIC.CFG') ;
- dos.exit(EXIT_PROCESS,1);
- End ;
-
- While Not Eof(ConfigFile) Do Begin
- ReadLn(ConfigFile,Line) ;
- Line := UpperCase(Trim(Line)) ;
- KeyWord := Field(Line,' ',1) ;
- If KeyWord = 'IN' Then
- InboundDir := Strip(Field(Line,' ',2),'\','T')
- Else If KeyWord = 'NETMAIL' Then
- Directory := Strip(Field(Line,' ',2),'\','T')
- Else If KeyWord = 'NET' Then
- Net := Str_To_Word(Field(Line,' ',2))
- Else If KeyWord = 'NODE' Then
- Node := Str_To_Word(Field(Line,' ',2))
- Else If (KeyWord = 'ZONE') And (Zone = 0) Then
- Zone := Str_To_Word(Field(Line,' ',2)) ;
- End ;
- Close(ConfigFile) ;
-
- ToZone := Zone ;
- ToNet := Net ;
- ToNode := Node ;
- ToPoint := Point ;
- End ;
-
- Procedure ParseCommandLine ;
-
- Var
- Idx : Word ;
- Cmd : String[2] ;
- Tmp : MAXSTRING ;
-
- Begin
- For Idx := 1 To ParamCount Do Begin
- Cmd := UpperCase(Copy(ParamStr(Idx),1,2)) ;
-
- If Cmd = '-M' Then
- Directory := Strip(Copy(ParamStr(Idx),3,Size(Directory)-1),'\','T')
- Else If Cmd = '-I' Then
- InboundDir := Strip(Copy(ParamStr(Idx),3,Size(InboundDir)-1),'\','T')
- Else If Cmd = '-S' Then
- Subject := Change(Copy(ParamStr(Idx),3,Size(Subject)-1),'_',' ')
- Else If Cmd = '-F' Then
- FromUser := Change(Copy(ParamStr(Idx),3,Size(FromUser)-1),'_',' ')
- Else If Cmd = '-T' Then
- ToUser := Change(Copy(ParamStr(Idx),3,Size(ToUser)-1),'_',' ')
- Else If Cmd = '-P' Then
- Private := True
- Else If Cmd = '-K' Then
- KillSent := True
- Else If Cmd = '-Z' Then
- ZoneGate := True
- Else If Cmd = '-A' Then Begin
- AreaCnt := AreaCnt + 1 ;
- If AreaCnt > MaxArea Then Begin
- WriteLn('To Many Areas Specified, Maximum is ',MaxArea) ;
- dos.exit(EXIT_PROCESS,1);
- End ;
- AreaList[AreaCnt] := Copy(ParamStr(Idx),3,Size(AreaList[AreaCnt])-1) ;
- End Else If Cmd = '-L' Then Begin
- LogFileName := Copy(ParamStr(Idx),3,Size(LogFileName)-1) ;
- If LogFileName = '' Then LogFileName := 'TICKET.LOG' ;
- End Else If Cmd = '-Q' Then Begin
- Assign(Output,'NUL') ;
- ReWrite(Output) ;
- End Else If Cmd = '-N' Then Begin
- Tmp := Copy(ParamStr(Idx),3,Size(Tmp)-1) ;
- If Tmp[1] = '*' Then Begin
- Delete(Tmp,1,1) ;
- ReadPlease(Tmp) ;
- End Else Begin
- NodeCnt := NodeCnt + 1 ;
- If NodeCnt > MaxNodes Then Begin
- WriteLn(Output,'To Many Nodes Specified - Maximum is ',MaxNodes) ;
- dos.exit(EXIT_PROCESS,1);
- End ;
- Fido_Address(Tmp,NodeList[NodeCnt].Zone,
- NodeList[NodeCnt].Net,
- NodeList[NodeCnt].Node,
- NodeList[NodeCnt].Point) ;
- End ;
- End ;
- End ;
- If NodeCnt = 0 Then Begin
- NodeCnt := 1 ;
- NodeList[NodeCnt].Zone := Zone ;
- NodeList[NodeCnt].Net := Net ;
- NodeList[NodeCnt].Node := Node ;
- NodeList[NodeCnt].Point := Point ;
- End ;
- End ;
-
- Function NextMessage: Word ;
-
- Var
- FileName : MAXSTRING ;
- MsgNo : Word ;
- Garbage : Word ;
- cnt : word;
- MsgHigh : Word ;
-
- Begin
- MsgHigh:= 1;
- tstr := Directory+'\*.MSG';
- StrToZ(tstr,ztstr);
- attr := 0;
- hndldir := HDIR_CREATE;
- cnt := 1;
- reslng := size(DirInfo);
- rsrvd := 0;
- retn := 0;
- retn := dos.FindFirst(ztstr,hndldir,attr,DirInfo,reslng,cnt,rsrvd) ;
- While retn = 0 Do Begin
- MsgNo := Str_To_Word(Field(DirInfo.Name,'.',1)) ;
- If MsgNo > MsgHigh Then MsgHigh := MsgNo ;
- retn := dos.FindNext(hndldir,DirInfo,reslng,cnt) ;
- End ;
- NextMessage := MsgHigh + 1 ;
- End ;
-
- Procedure StartMessage ;
- Var Count : Word ;
-
- Var
- Year : Word ;
- Month : Word ;
- Day : Word ;
- Dow : Word ;
- Hour : Word ;
- Minute : Word ;
- Second : Word ;
- Sec100 : Word ;
- MsgNo : Word ;
- Line : MAXSTRING ;
- DateTime : String[20] ;
-
- Begin
- Count:= 0;
- WriteLn(Output,'Inbound : ',InboundDir) ;
- WriteLn(Output,'Message : ',Directory) ;
- WriteLn(Output,'From : ',FromUser,' of ',Zone,':',Net,'/',Node,'.',Point) ;
- WriteLn(Output,'To : ',ToUser,' of ',ToZone,':',ToNet,'/',ToNode,'.',ToPoint) ;
- WriteLn(Output,'Subject : ',Subject) ;
- WriteLn(Output,'') ;
-
- GetDate(Year,Month,Day,Dow) ;
- GetTime(Hour,Minute,Second,Sec100) ;
-
- DateTime := PadRight(Word_To_Str(Day),2,'0')
- + ' ' + Copy(Date_DMA(Month),1,3)
- + ' ' + PadRight(Word_To_Str(Year),2,'0')
- + ' ' + PadRight(Word_To_Str(Hour),2,'0')
- + ':' + PadRight(Word_To_Str(Minute),2,'0')
- + ':' + PadRight(Word_To_Str(Second),2,'0') ;
-
- FillChar(MsgHdr,Size(MsgHdr),chr(0)) ;
-
- If (Zone <> ToZone) And ZoneGate Then Begin
- MsgHdr.DestNet := Zone ;
- MsgHdr.DestNode := ToZone ;
- End Else Begin
- MsgHdr.DestNet := ToNet ;
- MsgHdr.DestNode := ToNode ;
- End ;
-
- MsgHdr.OrigNet := Net ;
- MsgHdr.OrigNode := Node ;
-
- MsgHdr.Attribute := Msg_Local ; { Local Bit }
- If Private Then MsgHdr.Attribute := MsgHdr.Attribute OR Msg_Private ;
- If KillSent Then MsgHdr.Attribute := MsgHdr.Attribute OR Msg_Killsent ;
-
- Move(FromUser[1],MsgHdr.FromUser,Length(FromUser)) ;
- Move(ToUser[1] ,MsgHdr.ToUser ,Length(ToUser)) ;
- Move(Subject[1] ,MsgHdr.Subject ,Length(Subject)) ;
- Move(DateTime[1],MsgHdr.DateTime,Length(DateTime)) ;
- {$I-}
- IOCheck := FALSE;
- Assign(MsgFile,Directory + '\TICKET.$$$') ;
- ReWrite(MsgFile) ;
- {$I+}
- IOCheck := TRUE;
- If IOresult <> 0 Then Begin
- WriteLn('Unable to create message in ',Directory) ;
- dos.exit(EXIT_PROCESS,1);
- End ;
-
- _BLOCKWRITE(MsgFile,MsgHdr,Size(MsgHdr)) ;
-
- (* Handle FidoNet Addressing Kludges *)
-
- If Zone <> ToZone Then Begin
- Line := chr(1) + 'INTL'
- + ' ' + Word_To_Str(ToZone)
- + ':' + Word_To_Str(ToNet)
- + '/' + Word_To_Str(ToNode)
- + ' ' + Word_To_Str(Zone)
- + ':' + Word_To_Str(Net)
- + '/' + Word_To_Str(Node) + chr(13)+chr(10) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
- End ;
-
- If Point <> 0 Then Begin
- Line := chr(1) + 'FMPT ' + Word_To_Str(Point) + chr(13)+chr(10) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
- End ;
-
- If ToPoint <> 0 Then Begin
- Line := chr(1) + 'TOPT ' + Word_To_Str(ToPoint) + chr(13)+chr(10) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
- End ;
-
- Line := 'The Following Files were received for Processing' + chr(13)+chr(10)+chr(13)+chr(10) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
- End ;
-
- Procedure ProcessFile(Extn: MAXSTRING) ;
-
- Var
- TicFile : Text ;
- AreaNum : Word ;
- Line : MAXSTRING ;
- DirInfo : FILEFINDBUF ;
- Tmp : MAXSTRING ;
- AreaName : String[25] ;
- FileName : String[15] ;
- FileDate : String[8] ;
- FileDesc : String[60] ;
- FileOrig : String[15] ;
- FileByte : INTEGER ;
- Found : Boolean ;
- Idx : Word ;
- tstr2 : maxstring;
- fname : maxstring;
- cnt : word;
-
- Begin
- tstr := InboundDir+'\*.'+Extn;
- StrToZ(tstr,ztstr);
- attr := 0;
- hndldir := HDIR_CREATE;
- cnt := 1;
- reslng := size(DirInfo);
- rsrvd := 0;
- retn := 0;
- retn := dos.FindFirst(ztstr,hndldir,attr,DirInfo,reslng,cnt,rsrvd) ;
- While retn = 0 Do Begin
- fname := DirInfo.Name;
- fname[0] := (DirInfo.cname::char);
- WriteLn(Output,fname);
- {$I-}
- IOCheck := FALSE;
- tstr2 := InboundDir+'\'+fname;
- Assign(TicFile,tstr2);
- Reset(TicFile) ;
- If IOresult <> 0 Then Begin
- WriteLn(Output,'Unable to Open ',tstr2);
- dos.exit(EXIT_PROCESS,1);
- End ;
- {$I+}
- IOCheck := TRUE;
-
- AreaName := '' ;
- FileName := '' ;
- FileDesc := '' ;
- FileOrig := '' ;
-
- If Extn = 'FLE' Then Begin
- ReadLn(TicFile,Line) ;
- AreaName := Field(Line,' ',2) ;
- ReadLn(TicFile,FileName) ;
- ReadLn(TicFile,FileDesc) ;
- End ;
-
- While Not Eof(TicFile) Do Begin
- ReadLn(TicFile,Line) ;
- Line := Trim(Line) ;
- Tmp := UpperCase(Field(Line,' ',1)) ;
- If (Tmp[Length(Tmp)] = ':') Then Delete(Tmp,Length(Tmp),1) ;
- If Tmp = 'AREA' Then AreaName := Field(Line,' ',2) ;
- If Tmp = 'FILE' Then FileName := Field(Line,' ',2) ;
- If Tmp = 'DESC' Then FileDesc := Trim(Copy(Line,5,Size(FileDesc)-1)) ;
- If Tmp = 'ORIGIN' Then FileOrig := Field(Line,' ',2) ;
- End ;
-
- FileName := UpperCase(FileName) ;
- AreaName := UpperCase(AreaName) ;
-
- If AreaCnt > 0 Then Begin
- Idx := 1 ;
- Found := False ;
- While (Idx <= AreaCnt) And Not Found Do Begin
- WriteLn(AreaName,' ',Idx,AreaList[Idx]) ;
- If AreaName = AreaList[Idx] Then Found := True ;
- Idx := Idx + 1 ;
- End ;
- End Else
- Found := True ;
-
- If Found Then Begin
- GetFileDTTM(InboundDir+'\'+FileName, fsize,TimeRec);
- If TimeRec.Year = 0 Then Begin
- WriteLn(Output,'Unable to Find ',InboundDir,'\',FileName) ;
- FileDate := 'ERROR' ;
- FileByte := 0 ;
- End Else Begin
- FileDate := PadRight(Word_To_Str(TimeRec.Month),2,'0')
- + '/' + PadRight(Word_To_Str(TimeRec.Day),2,'0')
- + '/' + PadRight(Word_To_Str(TimeRec.Year),2,'0') ;
- FileByte := fsize ;
- End ;
-
- Line := PadLeft(FileName,14,' ')
- + PadLeft(FileDate,10,' ')
- + PadLeft('(' + MD(FileByte,0) + ' Bytes)',20,' ')
- + ' Origin: ' + FileOrig + chr(13)+chr(10) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
-
- Line := ' ' + AreaName + ' ' + FileDesc + chr(13)+chr(10)+chr(13)+chr(10) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
-
- If LogFileName <> '' Then Begin
- {$I-}
- IOCheck := FALSE;
- Assign(LogFile,LogFileName) ;
- Append(LogFile) ;
- {$I+}
- IOCheck := TRUE;
- If IOresult <> 0 Then Begin
- {$I-}
- IOCheck := FALSE;
- ReWrite(LogFile) ;
- {$I+}
- IOCheck := TRUE;
- If IOresult <> 0 Then Begin
- WriteLn(Output,'Unable to Create LogFile ') ;
- LogFileName := '' ;
- End ;
- End ;
- WriteLn(LogFile,
- PadLeft(FileName,14,' '),
- PadLeft(FileDate,10,' '),
- PadRight(Word_To_Str(FileByte),8,' '),
- ' ',AreaName,' ',FileDesc) ;
- Close(LogFile) ;
- End ;
- FileCnt := FileCnt + 1 ;
- End ;
- Close(TicFile) ;
- retn := dos.FindNext(hndldir,DirInfo,reslng,cnt) ;
- End ;
- End ;
-
- Procedure WrapUp ;
-
- Var
- OriginFile : Text ;
- Line : MAXSTRING ;
- MsgName : MAXSTRING ;
- OK : boolean;
-
- Begin
- Line := '--- Ticket ' + Version + chr(13)+chr(10) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
-
- {$I-}
- IOCheck := FALSE;
- Assign(OriginFile,Directory + '\ORIGIN') ;
- Reset(OriginFile) ;
- {$I+}
- IOCheck := TRUE;
- If IOresult = 0 Then Begin
- ReadLn(OriginFile,Line) ;
- Close(OriginFile) ;
- Line := ' * Origin: ' + Copy(Line,1,57) + ' '
- + '(' + Word_To_Str(Zone)
- + ':' + Word_To_Str(Net)
- + '/' + Word_To_Str(Node)
- + '.' + Word_To_Str(Point)
- + ')' + chr(13)+chr(10) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
- End ;
-
- Line := chr(0) ;
- _BLOCKWRITE(MsgFile,Line[1],Length(Line)) ;
-
- Close(MsgFile) ;
- If FileCnt = 0 Then Begin
- Erase(MsgFile) ;
- WriteLn(Output,'No Files Processed') ;
- End Else Begin
- IntToStr(NextMessage,MsgName,10,OK);
- MsgName := Directory + '\' + MsgName + '.MSG' ;
- WriteLn(Output,MsgName) ;
- Rename(MsgFile,MsgName) ;
- WriteLn(Output,FileCnt,' Files Processed') ;
- End ;
- End ;
-
- Begin
- Idx:= 0;
- AreaCnt:= 0;
- NodeCnt:= 0;
- ZoneGate:= False;
- KillSent:= False;
- Private:= False;
- ToPoint:= 0;
- ToNode:= 0;
- ToNet:= 0;
- ToZone:= 0;
- Point:= 0;
- Node:= 0;
- Net:= 0;
- Zone:= 0;
- FileCnt:= 0;
- FromUser:= 'TICKET V1.20.OS2.1';
- ToUser:= 'All';
- Subject:= 'Files Received For Processing';
- LogFileName:= '';
- Directory:= '.';
- InboundDir:= '.';
- Copyright ;
- ReadConfig ;
- ParseCommandLine ;
- For Idx := 1 To NodeCnt Do Begin
- FileCnt := 0 ;
- ToZone := NodeList[Idx].Zone ;
- ToNet := NodeList[Idx].Net ;
- ToNode := NodeList[Idx].Node ;
- ToPoint := NodeList[Idx].Point ;
- If ToZone = 0 Then ToZone := Zone ;
- StartMessage ;
- ProcessFile('FLE') ;
- ProcessFile('TIC') ;
- WrapUp ;
- End ;
- End.
-