SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00036 ANYTHING NOT OTHERWISE CLASSIFIED 1 05-28-9313:51ALL SWAG SUPPORT TEAM BOOKISBN.PAS IMPORT 14 {π For you Programming librarians: the following Turbo Pascal Programπ will verify any ISBN (International Standard Book Number).π}π(*******************************************************************)π Program VerifyISBN; { Verify any ISBN number. Turbo Pascal }π { 1992, 1993 Greg Vigneault }ππ Var ISBNstr : String[16];π loopc, ISBNlen, M, chksm : Byte;π beginπ WriteLn; WriteLn( 'ISBN Verification v0.1, Greg Vigneault',#10);ππ if ( ParamCount <> 1 ) then begin { we want just 1 input parm }π WriteLn( 'Syntax: ISBN <ISBN#>',#7 );π Halt(1);π end;π ISBNstr := ParamStr(1); { get ISBN# String }π Write( 'Checking ISBN# ', ISBNstr );π { eliminate any non-digit Characters from the ISBN String... }π ISBNlen := 0;π For loopc := 1 to orD( ISBNstr[0] ) doπ if ( ISBNstr[ loopc ] in ['0'..'9'] ) then beginπ inC( ISBNlen );π ISBNstr[ ISBNlen ] := ISBNstr[ loopc ];π end;π { an 'X' at the end of the ISBN affects the result }π if ( ISBNstr[ orD( ISBNstr[0] ) ] in ['X','x'] )π then M := 10π else M := orD( ISBNstr[ ISBNlen ] ) - 48;π ISBNstr[0] := CHR( ISBNlen ); { new ISBN str length }π chksm := 0;π For loopc := 1 to ISBNlen-1 doπ inC( chksm, ( orD( ISBNstr[ loopc ] ) - 48 ) * loopc );π Write( ' <--- ' );π if ( ( chksm MOD 11 ) = M )π then WriteLn( 'Okay' )π else WriteLn( 'ERRor!',#7 );π end {VerifyISBN}.π(********************************************************************)π 2 05-28-9313:51ALL SWAG SUPPORT TEAM CPAS-OBJ.PAS IMPORT 5 REYNIR STEFANSSONππ> Does anyone know of any way to convert a .TPU to a .BIN File toπ> use BIN2OBJ.EXE and then load it as an external? Any helpπ> appreciated...ππIt's a bit round-the-block, but you might get some exercise out of it,πassuming you have the source code:ππ1) Smash the source into C With a code converter.ππ2) Declare the Procedures as `void far PASCAL' and the Functions asπ `appropriate_Type far PASCAL'.ππ3) Compile it With Turbo C or similar.ππ 3 05-28-9313:51ALL SWAG SUPPORT TEAM DBASE4.PRG IMPORT 39 {πHello every one... Guys and gals is there any such a thing that you canπuse turbp pascal 6 with Dbase IV.. what I heard is I can.πif yes tell me how you export or whatever to use two of thewmπtogether,,,ππYes there is! I have been using it for some time now in dBase as I useπan XT and dBase's editor is too slow when the program has quite a fewπlines (some are 5,000) and the system just kind of dies. When I use TP'sπIDE the editor is FAST!!!! So after reading the books I designed aπprogram in order to use TP as using it in the TEDIT CONFIG.DB commandπwouldn't work as it needed more memory (I only have 640k).π}πππIn dBase's setup program, under the FILES MENU enter in eitherπPRGAPPLIC (overrides Application Control in the ASSIST menu only!) orπ Entry - C:\DBASEIV\EDIT2.PRGπ Exit - emptyπ Layout - emptyπPRGCC (allows you to use OPEN CUSTOM UTILIY option under Catalog Menu).π Entry - emptyπ Exit - emptyπ Layout - C:\DBASEIV\EDIT2.PRGππI am currently using PRGAPPLIC as I do most of my work in the ControlπCenter anyhow and don't need the Application Generator. Note - PRGCCπwill not pull in a PRG file unless you change the source code to ask forπone.ππHere is the dBase program that calls Turbo Pascal:ππ* <T>Program ----> EDIT2.PRGπ* <D>Language ---> dBase IV 1.5π* <P>Author -----> P.A.T. Systems° C.1993π* <T>Creation date -> 07/22/1992π* <L>Last update ---> 01/06/1993ππ* <G>From-> Control Centerπ* <N>To---> Noneπ* <T>Subs-> Noneππ* This program invokes an External Editor such as Turbo Pascal 6.0'sπ* (TP) Desktop Editor by using the PRGAPPLIC setup in the Config.dbπ* file. Even though it is only for Entry Programs, with some trickyπ* commands we can get it to invoke an External Editor such as TP.ππ* Although I can't do any Compiling or Help Lookup (another use for theπ* Manuals), it still is a great and FAST!!!! Editor to work with.ππ* This program will work with any editor that will accept a filenameπ* as a parameter.ππ* Example TURBO filename.prg (Turbo Pascal) ORπ* WP filename.prg (Word Perfect)ππ* As I am used to TP's Editor, I wished I could use it when I wanted toπ* edit a program. Especially a long program that when loaded intoπ* dBase's editor is extremely slow, but in TP, editing is FAST!!! Andπ* with dBase IV 1.5's NEW Open Architecture, I now have a way to do it.ππ* This program uses the RUN() function to swap out memory to disk soπ* that the editor can load in. With the TEDIT command in the Config.dbπ* setup, there wasn't enough memory (on an XT) to load in the editor.π* So I read the manuals (Yes, I do read them occasionally!) and figuredπ* out a way to use an External Editor by utilizing the Control Center'sπ* NEW Open Architecture.ππ* First, copy this program into dBase's Startup Directory.ππ* You next have to change dBase's setup using DBSETUP at the DOS promptπ* and load in the current configuration and then on the Files Menuπ* change the option of PRGAPPLIC so that it readsπ* "C:\DBASEIV\EDIT2.PRG". Once done, save the new configuration andπ* exit to DOS. Then enter dBase in your usual way. Next, create orπ* edit an existing program through the Control Center's Applicationπ* Menu. The Control Center will execute this .PRG file (it willπ* automatically compile it) and load up your Editor with the programπ* ready to edit!ππ* ***Note***π* This program will only work through the Control Center. If you typeπ* "MODI COMM filename" at the DOT PROMPT, the original editor will beπ* loaded as the Open Architecture only works with the Control Centerπ* applications.ππ* Hope you enjoy this program!!!!ππ* Parameters passed from Control Center to Application Designerπ* Panel Name, Filename (Programming in dBase IV - Chapter 17, pg 4)ππPARAMETERS cPanelName, cFileNameππ* Clear screen and turn on cursorπ* (MODI COMM turns off cursor when loading and then turns it backπ* on when editing - Why? I don't know. When I invoked my editor, Iπ* found that the cursor had disappeared, so I included this Commandπ* and my cursor came back!)ππCLEARπSET CURSOR ONππ* Store Editor's filename and dBase .PRG Filename to variable forπ* Macro Executionππ* (You can enter your own Editor's file name here if you wish, justπ* include the FULL PATH NAME just in case, and don't forget the SPACE!)ππ* uncomment this line for PRGCC or it will load CATALOG FILEπ* STORE "" TO cFileNameπSTORE "D:\TP\TURBO " + cFileName TO cExecEditππ* Invoke RUN() function to swap out memoryππSTORE RUN("&cExecEdit",.T.) TO nRunππ* Change filename so we can erase .DBO file for proper compilingπ* If creating a new file, no need to erase .DBO fileππIF .NOT. ISBLANK(cFileName)π STORE SUBSTR(cFileName, 1, AT(".PRG", cFileName)) + "DBO" TO ;π cExecEditππ* Erase the .DBO fileππ ERASE &cExecEditπENDIFππ* Return directly to Control Center instead of invoking Command EditorππRETURN TO MASTERππ* Endπ 4 05-28-9313:51ALL SWAG SUPPORT TEAM FLIPLAY.PAS IMPORT 255 {$G+}ππProgram FliPlayer;ππ{ v1.1 made by Thaco }π{ (c) EPOS, August 1992 }πππConstπ CLOCK_HZ =4608; { Frequency of clock }π MONItoR_HZ =70; { Frequency of monitor }π CLOCK_SCALE =CLOCK_HZ div MONItoR_HZ;ππ BUFFERSIZE =$FFFE; { Size of the framebuffer, must be an even number }π CDATA =$040; { Port number of timer 0 }π CMODE =$043; { Port number of timers control Word }π CO80 =$3; { Number For standard Text mode }π KEYBOARD =28; { Numbers returned by PorT[$64] indicating what hardware caused inT 09/the - }π MOUSE =60; { - number on PorT[$60] }π MCGA =$13; { Number For MCGA mode }π MCGACheck:Boolean =True; { Variable For MCGA checking }π UseXMS:Boolean =True; { Variable For XMS usage }π XMSError:Byte =0; { Variable indicating the errornumber returned from the last XMS operation }ππTypeπ EMMStructure =Recordπ BytestoMoveLo, { Low Word of Bytes to move. NB: Must be even! }π BytestoMoveHi, { High Word of Bytes to move }π SourceHandle, { Handle number of source (SH=0 => conventional memory) }π SourceoffsetLo, { Low Word of source offset, or ofS if SH=0 }π SourceoffsetHi, { High Word of source offset, or SEG if SH=0 }π DestinationHandle, { Handle number of destination (DH=0 => conventional memory) }π DestinationoffsetLo, { Low Word of destination offset, or ofS if DH=0 }π DestinationoffsetHi :Word; { High Word of destination offset, or SEG if DH=0 }π end;π HeaderType =Array[0..128] of Byte; { A bufferType used to read all kinds of headers }πππVarπ Key, { Variable used to check if a key has been pressed }π OldKey :Byte; { Variable used to check if a key has been pressed }π XMSRecord :EMMStructure; { Variable For passing values to the XMS routine }π InputFile :File; { Variable For the incomming .FLI File }π Header :HeaderType; { Buffer used to read all kinds of headers }π Counter, { General purpose counter }π Speed :Integer; { Timedifference in video tics from one frame to the next }π FileCounter, { Variable telling the point to read from in the File stored in XMS }π FileSize, { Size of the .FLI-File }π FrameSize, { Variable indicating the datasize of current frame }π NextTime, { Variable saying when it is time to move on to the next frame }π TimeCounter, { Holding the current time in video tics }π SecondPos :LongInt; { Number of Bytes to skip from the start of the .FLI File when starting - }π { - from the beginning again }π Buffer, { Pointer to the Framebuffer }π XMSEntryPoint :Pointer; { Entry point of the XMS routine in memory }π SpeedString :String[2]; { String used to parse the -sNN command }π FileName :String[13]; { String holding the name of the .FLI-File }π BufferHandle, { Handle number returned from the XMS routine }π BytesRead, { Variable telling the numbers of Bytes read from the .FLI File }π FrameNumber, { Number of the current frame }π Frames, { total number of frames }π Chunks :Word; { total number of chunks in a frame }πππFunction UpCaseString(Streng:String):String;π{ takes a String and convert all letters to upperCase }πVarπ DummyString :String;π Counter :Integer;πbeginπ DummyString:='';π For Counter:=1 to Length(Streng) doπ DummyString:=DummyString+UpCase(Streng[Counter]);π UpCaseString:=DummyString;πend;πππProcedure InitMode(Mode:Word); Assembler;π{ Uses BIOS interrupts to set a videomode }πAsmπ mov ax,Modeπ int 10hπend;πππFunction ModeSupport(Mode:Word):Boolean; Assembler;π{ Uses BIOS interrupts to check if a videomode is supported }πLabel Exit, Last_Modes, No_Support, Supported;πVarπ DisplayInfo :Array[1..64] of Byte; { Array For storing Functionality/state inFormation }πAsmπ push esππ mov ah,1Bh { the Functionality/state inFormation request at int 10h }π mov bx,0 { 0 = return Functionality/state inFormation }π push ds { push DS on the stack and pop it into ES so ES:DI could be used to - }π pop es { - address DisplayInfo, as demanded of the interrupt Function }π mov di,offset DisplayInfoπ int 10hππ les di,[dWord ptr es:di] { The first dWord in the buffer For state inFormation is the address - }π { - of static funtionality table }π mov cx,Mode { Can only check For the 0h-13h modes }π cmp cx,13hπ ja No_Support { Return 'no support' For modes > 13h }ππ mov ax,1 { Shift the right Byte the right - }π { - times and test For the right - }π cmp cx,10h { - bit For knowing if the - }π jae Last_Modes { - videomode is supported - }π { - }π shl ax,cl { - }π test ax,[Word ptr es:di+0] { - }π jz No_Support { - }π jmp Supported { - }π { - }πLast_Modes: { - }π sub cx,10h { - }π shl ax,cl { - }π test al,[Byte ptr es:di+2] { - }π jz No_Support { - }ππSupported:π mov al,1 { AL=1 makes the Function return True }π jmp ExitππNo_Support:π mov al,0 { AL=0 makes the Function return True }ππExit:π pop esπend;πππFunction NoXMS:Boolean; Assembler;π{ checks out if there is a XMS driver installed, and in Case it initialize theπ XMSEntryPoint Variable }πLabel JumpOver;πAsmπ push esππ mov ax,4300h { AX = 4300h => inSTALLATION CHECK }π int 2Fh { use int 2Fh Extended MEMorY SPECifICATION (XMS) }π mov bl,1 { use BL as a flag to indicate success }π cmp al,80h { is a XMS driver installed? }π jne JumpOverπ mov ax,4310h { AX = 4310h => GET DRIVER ADDRESS }π int 2Fhπ mov [Word ptr XMSEntryPoint+0],BX { initialize low Word of XMSEntryPoint }π mov [Word ptr XMSEntryPoint+2],ES { initialize high Word of XMSEntryPoint }π mov bl,0 { indicate success }πJumpOver:π mov al,bl { make the Function return True (AH=1) or False (AH=0) }ππ pop esπend;πππFunction XMSMaxAvail:Word; Assembler;π{ returns size of largest contiguous block of XMS in kilo (1024) Bytes }πLabel JumpOver;πAsmπ mov ah,08h { 'Query free Extended memory' Function }π mov XMSError,0 { clear error Variable }π call [dWord ptr XMSEntryPoint]π or ax,ax { check For error }π jnz JumpOverπ mov XMSError,bl { errornumber stored in BL }πJumpOver: { AX=largest contiguous block of XMS }πend;πππFunction XMSGetMem(SizeInKB:Word):Word; Assembler;π{ allocates specified numbers of kilo (1024) Bytes of XMS and return a handleπ to this XMS block }πLabel JumpOver;πAsmπ mov ah,09h { 'Allocate Extended memory block' Function }π mov dx,SizeInKB { number of KB requested }π mov XMSError,0 { clear error Variable }π call [dWord ptr XMSEntryPoint]π or ax,ax { check For error }π jnz JumpOverπ mov XMSError,bl { errornumber stored in BL }πJumpOver:π mov ax,dx { return handle number to XMS block }πend;πππProcedure XMSFreeMem(Handle:Word); Assembler;πLabel JumpOver;πAsmπ mov ah,0Ah { 'Free Extended memory block' Function }π mov dx,Handle { XMS's handle number to free }π mov XMSError,0 { clear error Variable }π call [dWord ptr XMSEntryPoint]π or ax,ax { check For error }π jnz JumpOverπ mov XMSError,bl { errornumber stored in BL }πJumpOver:πend;πππProcedure XMSMove(Var EMMParamBlock:EMMStructure); Assembler;πLabel JumpOver;πAsmπ push dsπ push esπ push dsπ pop esπ mov ah,0Bh { 'Move Extended memory block' Function }π mov XMSError,0 { clear error Variable }π lds si,EMMParamBlock { DS:SI -> data to pass to the XMS routine }π call [dWord ptr es:XMSEntryPoint]π or ax,ax { check For error }π jnz JumpOverπ mov XMSError,bl { errornumber stored in BL }πJumpOver:π pop esπ pop dsπend;πππProcedure ExitDuetoXMSError;πbeginπ InitMode(CO80);π WriteLn('ERRor! XMS routine has reported error ',XMSError);π XMSFreeMem(BufferHandle);π Halt(0);πend;πππProcedure GetBlock(Var Buffer; Size:Word);π{ reads a specified numbers of data from a diskFile or XMS into a buffer }πVarπ XMSRecord :EMMStructure;π NumberofBytes :Word;πbeginπ if UseXMS thenπ beginπ NumberofBytes:=Size;π if Size MOD 2=1 thenπ Inc(NumberofBytes); { one must allways ask For a EQUAL number of Bytes }π With XMSRecord doπ beginπ BytestoMoveLo :=NumberofBytes;π BytestoMoveHi :=0;π SourceHandle :=BufferHandle;π SourceoffsetLo :=FileCounter MOD 65536;π SourceoffsetHi :=FileCounter div 65536;π DestinationHandle :=0;π DestinationoffsetLo:=ofs(Buffer);π DestinationoffsetHi:=Seg(Buffer);π end;π XMSMove(XMSRecord);π if XMSError<>0 thenπ ExitDuetoXMSError;π Inc(FileCounter,Size);π endπ elseπ BlockRead(InputFile,Buffer,Size);πend;πππProcedure InitClock; Assembler; {Taken from the FLILIB source}πAsmπ mov al,00110100b { put it into liNear count instead of divide by 2 }π out CMODE,alπ xor al,alπ out CDATA,alπ out CDATA,alπend;πππFunction GetClock:LongInt; Assembler; {Taken from the FLILIB source}π{ this routine returns a clock With occassional spikes where timeπ will look like its running backwards 1/18th of a second. The resolutionπ of the clock is 1/(18*256) = 1/4608 second. 66 ticks of this clockπ are supposed to be equal to a monitor 1/70 second tick.}πAsmπ mov ah,0 { get tick count from Dos and use For hi 3 Bytes }π int 01ah { lo order count in DX, hi order in CX }π mov ah,dlπ mov dl,dhπ mov dh,clππ mov al,0 { read lo Byte straight from timer chip }π out CMODE,al { latch count }π mov al,1π out CMODE,al { set up to read count }π in al,CDATA { read in lo Byte (and discard) }π in al,CDATA { hi Byte into al }π neg al { make it so counting up instead of down }πend;πππProcedure TreatFrame(Buffer:Pointer;Chunks:Word); Assembler;π{ this is the 'workhorse' routine that takes a frame and put it on the screen }π{ chunk by chunk }πLabelπ Color_Loop, Copy_Bytes, Copy_Bytes2, Exit, Fli_Black, Fli_Brun, Fli_Color,π Fli_Copy, Fli_Lc, Fli_Loop, Jump_Over, Line_Loop, Line_Loop2, Next_Line,π Next_Line2, Pack_Loop, Pack_Loop2;πAsmπ cli { disable interrupts }π push dsπ push es π lds si,Buffer { let DS:SI point at the frame to be drawn }ππFli_Loop: { main loop that goes through all the chunks in a frame }π cmp Chunks,0 { are there any more chunks to draw? }π je Exitπ dec Chunks { decrement Chunks For the chunk to process now }ππ mov ax,[Word ptr ds:si+4] { let AX have the ChunkType }π add si,6 { skip the ChunkHeader }ππ cmp ax,0Bh { is it a FLI_COLor chunk? }π je Fli_Colorπ cmp ax,0Ch { is it a FLI_LC chunk? }π je Fli_Lcπ cmp ax,0Dh { is it a FLI_BLACK chunk? }π je Fli_Blackπ cmp ax,0Fh { is it a FLI_BRUN chunk? }π je Fli_Brunπ cmp ax,10h { is it a FLI_COPY chunk? }π je Fli_Copyπ jmp Fli_Loop { This command should not be necessary since the Program should make one - }π { - of the other jumps }ππFli_Color:π mov bx,[Word ptr ds:si] { number of packets in this chunk (allways 1?) }π add si,2 { skip the NumberofPackets }π mov al,0 { start at color 0 }π xor cx,cx { reset CX }ππColor_Loop:π or bx,bx { set flags }π jz Fli_Loop { Exit if no more packages }π dec bx { decrement NumberofPackages For the package to process now }ππ mov cl,[Byte ptr ds:si+0] { first Byte in packet tells how many colors to skip }π add al,cl { add the skiped colors to the start to get the new start }π mov dx,$3C8 { PEL Address Write Mode Register }π out dx,al { tell the VGA card what color we start changing }ππ inc dx { at the port abow the PEL_A_W_M_R is the PEL Data Register }π mov cl,[Byte ptr ds:si+1] { next Byte in packet tells how many colors to change }π or cl,cl { set the flags }π jnz Jump_Over { if NumberstoChange=0 then NumberstoChange=256 }π inc ch { CH=1 and CL=0 => CX=256 }πJump_Over:π add al,cl { update the color to start at }π mov di,cx { since each color is made of 3 Bytes (Red, Green & Blue) we have to - }π shl cx,1 { - multiply CX (the data counter) With 3 }π add cx,di { - CX = old_CX shl 1 + old_CX (the fastest way to multiply With 3) }π add si,2 { skip the NumberstoSkip and NumberstoChange Bytes }π rep outsb { put the color data to the VGA card FAST! }ππ jmp Color_Loop { finish With this packet - jump back }πππFli_Lc:π mov ax,0A000hπ mov es,ax { let ES point at the screen segment }π mov di,[Word ptr ds:si+0] { put LinestoSkip into DI - }π mov ax,di { - to get the offset address to this line we have to multiply With 320 - }π shl ax,8 { - DI = old_DI shl 8 + old_DI shl 6 - }π shl di,6 { - it is the same as DI = old_DI*256 + old_DI*64 = old_DI*320 - }π add di,ax { - but this way is faster than a plain mul }π mov bx,[Word ptr ds:si+2] { put LinestoChange into BX }π add si,4 { skip the LinestoSkip and LinestoChange Words }π xor cx,cx { reset cx }ππLine_Loop:π or bx,bx { set flags }π jz Fli_Loop { Exit if no more lines to change }π dec bxππ mov dl,[Byte ptr ds:si] { put PacketsInLine into DL }π inc si { skip the PacketsInLine Byte }π push di { save the offset address of this line }ππPack_Loop:π or dl,dl { set flags }π jz Next_Line { Exit if no more packets in this line }π dec dlπ mov cl,[Byte ptr ds:si+0] { put BytestoSkip into CL }π add di,cx { update the offset address }π mov cl,[Byte ptr ds:si+1] { put BytesofDatatoCome into CL }π or cl,cl { set flags }π jns Copy_Bytes { no SIGN means that CL number of data is to come - }π { - else the next data should be put -CL number of times }π mov al,[Byte ptr ds:si+2] { put the Byte to be Repeated into AL }π add si,3 { skip the packet }π neg cl { Repeat -CL times }π rep stosbπ jmp Pack_Loop { finish With this packet }ππCopy_Bytes: π add si,2 { skip the two count Bytes at the start of the packet }π rep movsbπ jmp Pack_Loop { finish With this packet }ππNext_Line:π pop di { restore the old offset address of the current line }π add di,320 { offset address to the next line }π jmp Line_LoopπππFli_Black:π mov ax,0A000hπ mov es,ax { let ES:DI point to the start of the screen }π xor di,diπ mov cx,32000 { number of Words in a screen }π xor ax,ax { color 0 is to be put on the screen }π rep stoswπ jmp Fli_Loop { jump back to main loop }πππFli_Brun:π mov ax,0A000hπ mov es,ax { let ES:DI point at the start of the screen }π xor di,diπ mov bx,200 { numbers of lines in a screen }π xor cx,cxππLine_Loop2:π mov dl,[Byte ptr ds:si] { put PacketsInLine into DL }π inc si { skip the PacketsInLine Byte }π push di { save the offset address of this line }ππPack_Loop2:π or dl,dl { set flags }π jz Next_Line2 { Exit if no more packets in this line }π dec dlπ mov cl,[Byte ptr ds:si] { put BytesofDatatoCome into CL }π or cl,cl { set flags }π js Copy_Bytes2 { SIGN meens that CL number of data is to come - }π { - else the next data should be put -CL number of times }π mov al,[Byte ptr ds:si+1] { put the Byte to be Repeated into AL }π add si,2 { skip the packet }π rep stosbπ jmp Pack_Loop2 { finish With this packet }ππCopy_Bytes2:π inc si { skip the count Byte at the start of the packet }π neg cl { Repeat -CL times }π rep movsbπ jmp Pack_Loop2 { finish With this packet }ππNext_Line2:π pop di { restore the old offset address of the current line }π add di,320 { offset address to the next line }π dec bx { any more lines to draw? }π jnz Line_Loop2π jmp Fli_Loop { jump back to main loop }πππFli_Copy:π mov ax,0A000hπ mov es,ax { let ES:DI point to the start of the screen }π xor di,diπ mov cx,32000 { number of Words in a screen }π rep movswπ jmp Fli_Loop { jump back to main loop }πππExit:π sti { enable interrupts }π pop esπ pop dsπend;ππππbeginπ WriteLn;π WriteLn('.FLI-Player v1.1 by Thaco');π WriteLn(' (c) EPOS, August 1992');π WriteLn;π if ParamCount=0 then { if no input parameters then Write the 'usage Text' }π beginπ WriteLn('USAGE: FLIPLAY <options> <Filename>');π WriteLn(' '+#24+' '+#24);π WriteLn(' │ └── Filename of .FLI File');π WriteLn(' └──────────── -d = Do not use XMS');π WriteLn(' -i = InFormation about the Program');π WriteLn(' -n = No checking of MCGA mode support');π WriteLn(' -sNN = Set playspeed to NN video ticks (0-99)');π WriteLn(' ( NN=70 ≈ frame Delay of 1 second )');π Halt(0);π end;ππ For Counter:=1 to ParamCount do { search through the input parameters For a -Info option }π if Pos('-I',UpCaseString(ParamStr(Counter)))<>0 thenπ beginπ WriteLn('Program inFormation:');π WriteLn('This Program plays animations (sequences of pictures) made by Programs like',#10#13,π 'Autodesk Animator (so called .FLI-Files). The Program decodes the .FLI File,',#10#13,π 'frame by frame, and Uses the systemclock For mesuring the time-Delay between',#10#13,π 'each frame.');π WriteLn('Basis For the Program was the FliLib package made by Jim Kent, but since the',#10#13,π 'original source was written in C, and I am not a good C-Writer, I decided',#10#13,π 'to Write my own .FLI-player in Turbo Pascal v6.0.');π WriteLn('This Program was made by Eirik Milch Pedersen (thaco@solan.Unit.no).');π WriteLn('Copyright Eirik Pedersens Own SoftwareCompany (EPOS), August 1992');π WriteLn;π WriteLn('Autodesk Animator is (c) Autodesk Inc');π WriteLn('FliLib is (c) Dancing Flame');π WriteLn('Turbo Pascal is (c) Borland International Inc');π Halt(0);π end;ππ Speed:=-1;π Counter:=1;π While (Copy(ParamStr(Counter),1,1)='-') and (ParamCount>=Counter) do { search through the input parameters to assemble them }π beginπ if Pos('-D',UpCaseString(ParamStr(Counter)))<>0 then { do not use XMS For storing the File into memory }π UseXMS:=Falseπ elseπ if Pos('-N',UpCaseString(ParamStr(Counter)))<>0 then { do not check For a vga card present }π MCGACheck:=Falseπ elseπ if Pos('-S',UpCaseString(ParamStr(Counter)))<>0 then { speed override has been specified }π beginπ SpeedString:=Copy(ParamStr(Counter),3,2); { cut out the NN parameter }π if not(SpeedString[1] in ['0'..'9']) or { check if the NN parameter is legal }π (not(SpeedString[2] in ['0'..'9',' ']) and (Length(SpeedString)=2)) thenπ beginπ WriteLn('ERRor! Can not parse speed ''',SpeedString,'''.');π Halt(0);π end;π Speed:=Byte(SpeedString[1])-48; { take the first number, in ASCII, and convert it to a standard number }π if Length(SpeedString)=2 then { if there is two numbers then multiply the first With 10 and add the next }π Speed:=Speed*10+Byte(SpeedString[2])-48;π Speed:=Speed*CLOCK_SCALE; { convert the speed to number of clock tics }π end;π Inc(Counter);π end;ππ if ParamCount<Counter thenπ beginπ WriteLn('ERRor! No Filename specified.');π Halt(0);π end;ππ FileName:=UpCaseString(ParamStr(Counter));π if Pos('.',FileName)=0 then { find out if there exist a . in the Filename }π FileName:=FileName+'.FLI'; { if not then add the .FLI extension on the Filename }ππ if MaxAvail<BUFFERSIZE then { check if there is enough memory to the frame buffer }π beginπ WriteLn('ERRor! Can not allocate enough memory to a frame buffer.');π Halt(0);π end;ππ GetMem(Buffer,BUFFERSIZE);π Assign(InputFile,FileName);π Reset(InputFile,1);π if Ioresult<>0 then { has an error occured during opening the File? }π beginπ WriteLn('ERRor! Can not open File ''',FileName,'''.');π Halt(0);π end;ππ if not(MCGACheck) or ModeSupport(MCGA) thenπ InitMode(MCGA)π elseπ beginπ WriteLn('ERRor! Video mode 013h - 320x200x256 colors - is not supported.');π Halt(0);π end;ππ BlockRead(InputFile,Header,128); { read the .FLI main header }ππ if not((Header[4]=$11) and (Header[5]=$AF)) then { check if the File has got the magic number }π beginπ InitMode(CO80);π WriteLn('ERRor! File ''',FileName,''' is of a wrong File Type.');π Halt(0);π end;ππ if NoXMS then { if no XMS driver present then do not use XMS }π UseXMS:=False;ππ if UseXMS thenπ beginπ FileSize:=Header[0]+256*(LongInt(Header[1])+256*(LongInt(Header[2])+256*LongInt(Header[3])));π if XMSMaxAvail<=(FileSize+1023) SHR 10 then { is there enough XMS (rounded up to Nearest KB) availible? }π beginπ WriteLn('ERRor! not enough XMS For the File');π Halt(0);π endπ elseπ beginπ Seek(InputFile,0); { skip back to start of .FLI-File to put it all into XMS }π BufferHandle:=XMSGetMem((FileSize+1023) SHR 10); { allocate XMS For the whole .FLI File }π FileCounter:=0;π Repeatπ BlockRead(InputFile,Buffer^,BUFFERSIZE,BytesRead); { read a part from the .FLI File }π if BytesRead MOD 2=1 then { since BUFFERSIZE shoud be an even number, the only time this triggers is the last part }π Inc(BytesRead); { must be done because the XMS routine demands an even number of Bytes to be moved }π if BytesRead<>0 thenπ beginπ With XMSRecord do { put data into the XMSRecord }π beginπ BytestoMoveLo :=BytesRead;π BytestoMoveHi :=0;π SourceHandle :=0;π SourceoffsetLo :=ofs(Buffer^);π SourceoffsetHi :=Seg(Buffer^);π DestinationHandle :=BufferHandle;π DestinationoffsetLo:=FileCounter MOD 65536;π DestinationoffsetHi:=FileCounter div 65536;π end;π XMSMove(XMSRecord); { move Bytes to XMS }π if XMSError<>0 then { have any XMS errors occured? }π ExitDuetoXMSError;π Inc(FileCounter,BytesRead); { update the offset into XMS where to put the next Bytes }π end;π Until BytesRead<>BUFFERSIZE; { Repeat Until Bytes read <> Bytes tried to read => end of File }π end;π FileCounter:=128; { we continue (after reading the .FLI File into XMS) right after the .FLI main header }π end;ππ Frames:=Header[6]+Header[7]*256; { get the number of frames from the .FLI-header }π if Speed=-1 then { if speed is not set by a speed override then get it from the .FLI-header }π Speed:=(Header[16]+Integer(Header[17])*256)*CLOCK_SCALE;π InitClock; { initialize the System Clock }π OldKey:=PorT[$60]; { get the current value from the keyboard }π Key:=OldKey; { and set the 'current key' Variable to the same value }ππ GetBlock(Header,16); { read the first frame-header }π FrameSize:=Header[0]+256*(LongInt(Header[1])+256*(LongInt(Header[2])+256*LongInt(Header[3])))-16; { calculate framesize }π SecondPos:=128+16+FrameSize; { calculate what position to skip to when the .FLI is finished and is going to start again - }π { the position = .FLI-header + first_frame-header + first_framesize }π Chunks:=Header[6]+Header[7]*256; { calculate number of chunks in frame }π GetBlock(Buffer^,FrameSize); { read the frame into the framebuffer }π TreatFrame(Buffer,Chunks); { treat the first frame }ππ TimeCounter:=GetClock; { get the current time }ππ {π The first frame must be handeled separatly from the rest. This is because the rest of the frames are updates/changes of theπ first frame.π At the end of the .FLI-File there is one extra frame who handles the changes from the last frame to the first frame.π }ππ Repeatπ FrameNumber:=1; { we start at the first frame (after the initial frame) }π Repeatπ GetBlock(Header,16); { read frame-header }π FrameSize:=Header[0]+256*(LongInt(Header[1])+256*(LongInt(Header[2])+256*LongInt(Header[3])))-16; { size of frame }π if FrameSize<>0 then { sometimes there are no changes from one frame to the next (used For extra Delays). In such - }π { - Cases the size of the frame is 0 and we don't have to process them }π beginπ Chunks:=Header[6]+Header[7]*256; { calculate number of chunks in the frame }π GetBlock(Buffer^,FrameSize); { read the frame into the framebuffer }π TreatFrame(Buffer,Chunks); { treat the frame }π end;ππ NextTime:=TimeCounter+Speed; { calculate the Delay to the next frame }π While TimeCounter<NextTime do { wait For this long }π TimeCounter:=GetClock;ππ if PorT[$64]=KEYBOARD then { check if the value at the keyboard port is caused by a key pressed }π Key:=PorT[$60]; { get the current value from the keyboard }π Inc(FrameNumber); { one frame finished, over to the next one }π Until (FrameNumber>Frames) or (Key<>OldKey); { Repeated Until we come to the last frame or a key is pressed }ππ if UseXMS thenπ FileCounter:=SecondPosπ elseπ Seek(InputFile,SecondPos); { set current position in the File to the second frame }ππ Until Key<>OldKey; { Exit the loop if a key has been pressed }ππ InitMode(CO80); { get back to Text mode }ππ Close(InputFile); { be a kind boy and close the File beFore we end the Program }π FreeMem(Buffer,BUFFERSIZE); { and free the framebuffer }ππ if UseXMS thenπ XMSFreeMem(BufferHandle);πEND. 5 05-28-9313:51ALL SWAG SUPPORT TEAM GLOBALS.PAS IMPORT 146 Unit globals;ππ{ Use this Unit For Procedures, Functions and Variables that every Program youπ Write will share.π}ππInterfaceππUses π Dos;π πTypeπ str1 = String[1]; str2 = String[2]; str3 = String[3];π str4 = String[4]; str5 = String[5]; str6 = String[6];π str7 = String[7]; str8 = String[8]; str9 = String[9];π str10 = String[10]; str11 = String[11]; str12 = String[12];π str13 = String[13]; str14 = String[14]; str15 = String[15];π str16 = String[16]; str17 = String[17]; str18 = String[18];π str19 = String[19]; str20 = String[20]; str21 = String[21];π str22 = String[22]; str23 = String[23]; str24 = String[24];π str25 = String[25]; str26 = String[26]; str27 = String[27];π str28 = String[28]; str29 = String[29]; str30 = String[30];π str31 = String[31]; str32 = String[32]; str33 = String[33];π str34 = String[34]; str35 = String[35]; str36 = String[36];π str37 = String[37]; str38 = String[38]; str39 = String[39];π str40 = String[40]; str41 = String[41]; str42 = String[42];π str43 = String[43]; str44 = String[44]; str45 = String[45];π str46 = String[46]; str47 = String[47]; str48 = String[48];π str49 = String[49]; str50 = String[50]; str51 = String[51];π str52 = String[52]; str53 = String[53]; str54 = String[54];π str55 = String[55]; str56 = String[56]; str57 = String[57];π str58 = String[58]; str59 = String[59]; str60 = String[60];π str61 = String[61]; str62 = String[62]; str63 = String[63];π str64 = String[64]; str65 = String[65]; str66 = String[66];π str67 = String[67]; str68 = String[68]; str69 = String[69];π str70 = String[70]; str71 = String[71]; str72 = String[72];π str73 = String[73]; str74 = String[74]; str75 = String[75];π str76 = String[76]; str77 = String[77]; str78 = String[78];π str79 = String[79]; str80 = String[80]; str81 = String[81];π str82 = String[82]; str83 = String[83]; str84 = String[84];π str85 = String[85]; str86 = String[86]; str87 = String[87];π str88 = String[88]; str89 = String[89]; str90 = String[90];π str91 = String[91]; str92 = String[92]; str93 = String[93];π str94 = String[94]; str95 = String[95]; str96 = String[96];π str97 = String[97]; str98 = String[98]; str99 = String[99];π str100 = String[100]; str101 = String[101]; str102 = String[102];π str103 = String[103]; str104 = String[104]; str105 = String[105];π str106 = String[106]; str107 = String[107]; str108 = String[108];π str109 = String[109]; str110 = String[110]; str111 = String[111];π str112 = String[112]; str113 = String[113]; str114 = String[114];π str115 = String[115]; str116 = String[116]; str117 = String[117];π str118 = String[118]; str119 = String[119]; str120 = String[120];π str121 = String[121]; str122 = String[122]; str123 = String[123];π str124 = String[124]; str125 = String[125]; str126 = String[126];π str127 = String[127]; str128 = String[128]; str129 = String[129];π str130 = String[130]; str131 = String[131]; str132 = String[132];π str133 = String[133]; str134 = String[134]; str135 = String[135];π str136 = String[136]; str137 = String[137]; str138 = String[138];π str139 = String[139]; str140 = String[140]; str141 = String[141];π str142 = String[142]; str143 = String[143]; str144 = String[144];π str145 = String[145]; str146 = String[146]; str147 = String[147];π str148 = String[148]; str149 = String[149]; str150 = String[150];π str151 = String[151]; str152 = String[152]; str153 = String[153];π str154 = String[154]; str155 = String[155]; str156 = String[156];π str157 = String[157]; str158 = String[158]; str159 = String[159];π str160 = String[160]; str161 = String[161]; str162 = String[162];π str163 = String[163]; str164 = String[164]; str165 = String[165];π str166 = String[166]; str167 = String[167]; str168 = String[168];π str169 = String[169]; str170 = String[170]; str171 = String[171];π str172 = String[172]; str173 = String[173]; str174 = String[174];π str175 = String[175]; str176 = String[176]; str177 = String[177];π str178 = String[178]; str179 = String[179]; str180 = String[180];π str181 = String[181]; str182 = String[182]; str183 = String[183];π str184 = String[184]; str185 = String[185]; str186 = String[186];π str187 = String[187]; str188 = String[188]; str189 = String[189];π str190 = String[190]; str191 = String[191]; str192 = String[192];π str193 = String[193]; str194 = String[194]; str195 = String[195];π str196 = String[196]; str197 = String[197]; str198 = String[198];π str199 = String[199]; str200 = String[200]; str201 = String[201];π str202 = String[202]; str203 = String[203]; str204 = String[204];π str205 = String[205]; str206 = String[206]; str207 = String[207];π str208 = String[208]; str209 = String[209]; str210 = String[210];π str211 = String[211]; str212 = String[212]; str213 = String[213];π str214 = String[214]; str215 = String[215]; str216 = String[216];π str217 = String[217]; str218 = String[218]; str219 = String[219];π str220 = String[220]; str221 = String[221]; str222 = String[222];π str223 = String[223]; str224 = String[224]; str225 = String[225];π str226 = String[226]; str227 = String[227]; str228 = String[228];π str229 = String[229]; str230 = String[230]; str231 = String[231];π str232 = String[232]; str233 = String[233]; str234 = String[234];π str235 = String[235]; str236 = String[236]; str237 = String[237];π str238 = String[238]; str239 = String[239]; str240 = String[240];π str241 = String[241]; str242 = String[242]; str243 = String[243];π str244 = String[244]; str245 = String[245]; str246 = String[246];π str247 = String[247]; str248 = String[248]; str249 = String[249];π str250 = String[250]; str251 = String[251]; str252 = String[252];π str253 = String[253]; str254 = String[254]; str255 = String[255];ππConstπ MaxWord = $ffff;π MinWord = 0;π MinInt = Integer($8000);π MinLongInt = $80000000;π UseCfg = True;ππ {Color Constants:π Black = 0; Blue = 1; Green = 2; Cyan = 3; Red = 4;π Magenta = 5; Brown = 6; LtGray = 7;π DkGray = 8; LtBlue = 9; LtGreen = A; LtCyan = B; LtRed = C;π LtMagenta = D; Yellow = E; White = Fπ }ππConst Blink = $80;ππ {Screen color Constants}πConst BlackOnBlack = $00; BlueOnBlack = $01;πConst BlackOnBlue = $10; BlueOnBlue = $11;πConst BlackOnGreen = $20; BlueOnGreen = $21;πConst BlackOnCyan = $30; BlueOnCyan = $31;πConst BlackOnRed = $40; BlueOnRed = $41;πConst BlackOnMagenta = $50; BlueOnMagenta = $51;πConst BlackOnBrown = $60; BlueOnBrown = $61;πConst BlackOnLtGray = $70; BlueOnLtGray = $71;πConst GreenOnBlack = $02; CyanOnBlack = $03;πConst GreenOnBlue = $12; CyanOnBlue = $13;πConst GreenOnGreen = $22; CyanOnGreen = $23;πConst GreenOnCyan = $32; CyanOnCyan = $33;πConst GreenOnRed = $42; CyanOnRed = $43;πConst GreenOnMagenta = $52; CyanOnMagenta = $53;πConst GreenOnBrown = $62; CyanOnBrown = $63;πConst GreenOnLtGray = $72; CyanOnLtGray = $73;πConst RedOnBlue = $14; MagentaOnBlue = $15;πConst RedOnGreen = $24; MagentaOnGreen = $25;πConst RedOnCyan = $34; MagentaOnCyan = $35;πConst RedOnRed = $44; MagentaOnRed = $45;πConst RedOnMagenta = $54; MagentaOnMagenta = $55;πConst RedOnBrown = $64; MagentaOnBrown = $65;πConst RedOnLtGray = $74; MagentaOnLtGray = $75;πConst BrownOnBlack = $06; LtGrayOnBlack = $07;πConst BrownOnBlue = $16; LtGrayOnBlue = $17;πConst BrownOnGreen = $26; LtGrayOnGreen = $27;πConst BrownOnCyan = $36; LtGrayOnCyan = $37;πConst BrownOnRed = $46; LtGrayOnRed = $47;πConst BrownOnMagenta = $56; LtGrayOnMagenta = $57;πConst BrownOnBrown = $66; LtGrayOnBrown = $67;πConst BrownOnLtGray = $76; LtGrayOnLtGray = $77;πConst DkGrayOnBlack = $08; LtBlueOnBlack = $09;πConst DkGrayOnBlue = $18; LtBlueOnBlue = $19;πConst DkGrayOnGreen = $28; LtBlueOnGreen = $29;πConst DkGrayOnCyan = $38; LtBlueOnCyan = $39;πConst DkGrayOnRed = $48; LtBlueOnRed = $49;πConst DkGrayOnMagenta = $58; LtBlueOnMagenta = $59;πConst DkGrayOnBrown = $68; LtBlueOnBrown = $69;πConst DkGrayOnLtGray = $78; LtBlueOnLtGray = $79;πConst LtGreenOnBlack = $0A; LtCyanOnBlack = $0B;πConst LtGreenOnBlue = $1A; LtCyanOnBlue = $1B;πConst LtGreenOnGreen = $2A; LtCyanOnGreen = $2B;πConst LtGreenOnCyan = $3A; LtCyanOnCyan = $3B;πConst LtGreenOnRed = $4A; LtCyanOnRed = $4B;πConst LtGreenOnMagenta = $5A; LtCyanOnMagenta = $5B;πConst LtGreenOnBrown = $6A; LtCyanOnBrown = $6B;πConst LtGreenOnLtGray = $7A; LtCyanOnLtGray = $7B;πConst LtRedOnBlue = $1C; LtMagentaOnBlue = $1D;πConst LtRedOnGreen = $2C; LtMagentaOnGreen = $2D;πConst LtRedOnCyan = $3C; LtMagentaOnCyan = $3D;πConst LtRedOnRed = $4C; LtMagentaOnRed = $4D;πConst LtRedOnMagenta = $5C; LtMagentaOnMagenta = $5D;πConst LtRedOnBrown = $6C; LtMagentaOnBrown = $6D;πConst LtRedOnLtGray = $7C; LtMagentaOnLtGray = $7D;πConst YellowOnBlack = $0E; WhiteOnBlack = $0F;πConst YellowOnBlue = $1E; WhiteOnBlue = $1F;πConst YellowOnGreen = $2E; WhiteOnGreen = $2F;πConst YellowOnCyan = $3E; WhiteOnCyan = $3F;πConst YellowOnRed = $4E; WhiteOnRed = $4F;πConst YellowOnMagenta = $5E; WhiteOnMagenta = $5F;πConst YellowOnBrown = $6E; WhiteOnBrown = $6F;πConst YellowOnLtGray = $7E; WhiteOnLtGray = $7F;πConst BlackOnDkGray = Blink + $00; BlueOnDkGray = Blink + $01;πConst BlackOnLtBlue = Blink + $10; BlueOnLtBlue = Blink + $11;πConst BlackOnLtGreen = Blink + $20; BlueOnLtGreen = Blink + $21;πConst BlackOnLtCyan = Blink + $30; BlueOnLtCyan = Blink + $31;πConst BlackOnLtRed = Blink + $40; BlueOnLtRed = Blink + $41;πConst BlackOnLtMagenta = Blink + $50; BlueOnLtMagenta = Blink + $51;πConst BlackOnYellow = Blink + $60; BlueOnYellow = Blink + $61;πConst BlackOnWhite = Blink + $70; BlueOnWhite = Blink + $71;πConst GreenOnDkGray = Blink + $02; CyanOnDkGray = Blink + $03;πConst GreenOnLtBlue = Blink + $12; CyanOnLtBlue = Blink + $13;πConst GreenOnLtGreen = Blink + $22; CyanOnLtGreen = Blink + $23;πConst GreenOnLtCyan = Blink + $32; CyanOnLtCyan = Blink + $33;πConst GreenOnLtRed = Blink + $42; CyanOnLtRed = Blink + $43;πConst GreenOnLtMagenta = Blink + $52; CyanOnLtMagenta = Blink + $53;πConst GreenOnYellow = Blink + $62; CyanOnYellow = Blink + $63;πConst GreenOnWhite = Blink + $72; CyanOnWhite = Blink + $73;πConst RedOnDkGray = Blink + $04; MagentaOnDkGray = Blink + $05;πConst RedOnLtBlue = Blink + $14; MagentaOnLtBlue = Blink + $15;πConst RedOnLtGreen = Blink + $24; MagentaOnLtGreen = Blink + $25;πConst RedOnLtCyan = Blink + $34; MagentaOnLtCyan = Blink + $35;πConst RedOnLtRed = Blink + $44; MagentaOnLtRed = Blink + $45;πConst RedOnLtMagenta = Blink + $54; MagentaOnLtMagenta= Blink + $55;πConst RedOnYellow = Blink + $64; MagentaOnYellow = Blink + $65;πConst RedOnWhite = Blink + $74; MagentaOnWhite = Blink + $75;πConst BrownOnDkGray = Blink + $06; LtGrayOnDkGray = Blink + $07;πConst BrownOnLtBlue = Blink + $16; LtGrayOnLtBlue = Blink + $17;πConst BrownOnLtGreen = Blink + $26; LtGrayOnLtGreen = Blink + $27;πConst BrownOnLtCyan = Blink + $36; LtGrayOnLtCyan = Blink + $37;πConst BrownOnLtRed = Blink + $46; LtGrayOnLtRed = Blink + $47;πConst BrownOnLtMagenta = Blink + $56; LtGrayOnLtMagenta = Blink + $57;πConst BrownOnYellow = Blink + $66; LtGrayOnYellow = Blink + $67;πConst BrownOnWhite = Blink + $76; LtGrayOnWhite = Blink + $77;πConst DkGrayOnDkGray = Blink + $08; LtBlueOnDkGray = Blink + $09;πConst DkGrayOnLtBlue = Blink + $18; LtBlueOnLtBlue = Blink + $19;πConst DkGrayOnLtGreen = Blink + $28; LtBlueOnLtGreen = Blink + $29;πConst DkGrayOnLtCyan = Blink + $38; LtBlueOnLtCyan = Blink + $39;πConst DkGrayOnLtRed = Blink + $48; LtBlueOnLtRed = Blink + $49;πConst DkGrayOnLtMagenta = Blink + $58; LtBlueOnLtMagenta = Blink + $59;πConst DkGrayOnYellow = Blink + $68; LtBlueOnYellow = Blink + $69;πConst DkGrayOnWhite = Blink + $78; LtBlueOnWhite = Blink + $79;πConst LtGreenOnDkGray = Blink + $0A; LtCyanOnDkGray = Blink + $0B;πConst LtGreenOnLtBlue = Blink + $1A; LtCyanOnLtBlue = Blink + $1B;πConst LtGreenOnLtGreen = Blink + $2A; LtCyanOnLtGreen = Blink + $2B;πConst LtGreenOnLtCyan = Blink + $3A; LtCyanOnLtCyan = Blink + $3B;πConst LtGreenOnLtRed = Blink + $4A; LtCyanOnLtRed = Blink + $4B;πConst LtGreenOnLtMagenta= Blink + $5A; LtCyanOnLtMagenta = Blink + $5B;πConst LtGreenOnYellow = Blink + $6A; LtCyanOnYellow = Blink + $6B;πConst LtGreenOnWhite = Blink + $7A; LtCyanOnWhite = Blink + $7B;πConst LtRedOnDkGray = Blink + $0C; LtMagentaOnDkGray = Blink + $0D;πConst LtRedOnLtBlue = Blink + $1C; LtMagentaOnLtBlue = Blink + $1D;πConst LtRedOnLtGreen = Blink + $2C; LtMagentaOnLtGreen= Blink + $2D;πConst LtRedOnLtCyan = Blink + $3C; LtMagentaOnLtCyan = Blink + $3D;πConst LtRedOnLtRed = Blink + $4C; LtMagentaOnLtRed = Blink + $4D;πConst LtRedOnLtMagenta = Blink + $5C; LtMagentaOnLtMagenta= Blink + $5D;πConst LtRedOnYellow = Blink + $6C; LtMagentaOnYellow = Blink + $6D;πConst LtRedOnWhite = Blink + $7C; LtMagentaOnWhite = Blink + $7D;πConst YellowOnDkGray = Blink + $0E; WhiteOnDkGray = Blink + $0F;πConst YellowOnLtBlue = Blink + $1E; WhiteOnLtBlue = Blink + $1F;πConst YellowOnLtGreen = Blink + $2E; WhiteOnLtGreen = Blink + $2F;πConst YellowOnLtCyan = Blink + $3E; WhiteOnLtCyan = Blink + $3F;πConst YellowOnLtRed = Blink + $4E; WhiteOnLtRed = Blink + $4F;πConst YellowOnLtMagenta = Blink + $5E; WhiteOnLtMagenta = Blink + $5F;πConst YellowOnYellow = Blink + $6E; WhiteOnYellow = Blink + $6F;πConst YellowOnWhite = Blink + $7E; WhiteOnWhite = Blink + $7F;ππVarπ TempStr : String;π TempStrLen : Byte Absolute TempStr;π πFunction Exist(fn: str80): Boolean;π{ Returns True if File fn exists in the current directory }ππFunction ExistsOnPath(Var fn: str80): Boolean;π{ Returns True if File fn exists in any directory specified in the current }π{ path and changes fn to a fully qualified path/File. }ππFunction StrUpCase(s : String): String;π{ Returns an upper Case String from s. Applicable to the English language. }ππFunction StrLowCase(s : String): String;π{ Returns a String = to s With all upper Case Characters converted to lower }ππFunction Asc2Str(Var s; max: Byte): String;π{ Converts an ASCIIZ String to a Turbo Pascal String With a maximum length }π{ of max Characters. }ππProcedure Str2Asc(s: String; Var ascStr; max: Word);π{ Converts a TP String to an ASCIIZ String of no more than max length. }π{ WARNinG: No checks are made that there is sufficient room in destination }π{ Variable. }ππFunction LastPos(ch: Char; s: String): Byte;π{ Returns the last position of ch in s }ππProcedure CheckIO(a: Byte);ππImplementationππFunction Exist(fn: str80): Boolean;π beginπ TempStrLen := 0;π TempStr := FSearch(fn,'');π Exist := TempStrLen <> 0;π end; { Exist }ππFunction ExistsOnPath(Var fn: str80): Boolean;π beginπ TempStrLen := 0;π TempStr := FSearch(fn,GetEnv('PATH'));π ExistsOnPath := TempStrLen <> 0;π fn := FExpand(TempStr);π end; { ExistsOnPath }ππFunction StrUpCase(s : String): String;π Var x : Byte;π beginπ StrUpCase[0] := s[0];π For x := 1 to length(s) doπ StrUpCase[x] := UpCase(s[x]);π end; { StrUpCase }ππFunction StrLowCase(s : String): String;π Var x : Byte;π beginπ StrLowCase[0] := s[0];π For x := 1 to length(s) doπ Case s[x] ofπ 'a'..'z': StrLowCase[x] := chr(ord(s[x]) and $df);π else StrLowCase[x] := s[x];π end; { Case }π end; { StrLowCase }ππFunction Asc2Str(Var s; max: Byte): String;π Var stArray : Array[1..255] of Char Absolute s;π len : Integer;π beginπ len := pos(#0,stArray)-1; { Get the length }π if (len > max) or (len < 0) then { length exceeds maximum }π len := max; { so set to maximum }π Asc2Str := stArray;π Asc2Str[0] := chr(len); { Set length }π end; { Asc2Str }ππProcedure Str2Asc(s: String; Var ascStr; max: Word);π beginπ FillChar(AscStr,max,0);π if length(s) < max thenπ move(s[1],AscStr,length(s))π elseπ move(s[1],AscStr,max);π end; { Str2Asc }πππFunction LastPos(ch: Char; s: String): Byte;π Var x : Word;π beginπ x := succ(length(s));π Repeatπ dec(x);π Until (s[x] = ch) or (x = 0);π end; { LastPos }ππProcedure CheckIO(a: Byte);π Var e : Integer;π beginπ e := Ioresult;π if e <> 0 then beginπ Writeln('I/O error ',e,' section ',a);π halt(e);π end;π end; { CheckIO }ππend. { Globals }π π 6 05-28-9313:51ALL SWAG SUPPORT TEAM HEBREW.PAS IMPORT 118 {πDAVID SOLLYππFrom Israel Moshe Harel was heard to say to David SollyππThank you For taking the time to answer my many questions. I have toπtell you, though, that I was lucky to have received your letter becauseπit was addressed to David SALLY and not David SOLLY.ππ> Are you familiar With a Hebrew Text processor Program called QText?π> I have been able to obtain version 2.10 as public domain software but Iπ> am wondering if there has been an update. Have you ever heard of aππMH>Current version of QText is 5.0 and it is commercial :-(π >It comes now With a full set of utilities, including FAX support.ππDid you know that Q-Text version 2.10 was written in Turbo Pascal 3? Iπwonder if Itschak Maynts (Isaac Mainz?) has continued to use it in hisπlater versions. Anyway, I would be interested in obtaining the latestπversion of Q-Text. Can you give me the distributor's address and theπapproximate price? Thank you.ππ>Most Israeli Printers have a special ROM. You may use downloadable Characterπ>sets or even Graphic printing if needed. I once used LETTRIX For this purposπ>on a Hebrew-less Printer, and it worked fine (but S L O W . . .).πππI have Letrix 3.6. This was what I was trying to use to print theπQ-Text Files I was writing. I wrote a Program in Turbo Pascal toπconvert the Q-Text Files into Letrix Files. The printing is slow butπthe results are favourable. Another advantage to Letrix Hebrew Files isπthat they are written completely in low-ASCII and almost readableπwithout transliteration if one is at all familiar With Hebrew. It is aπgood format For posting Hebrew Text on the Multi-Lingual echo not onlyπbecause it is low-ASCII but also because the method of transliterationπis consistent.ππBelow is my Q-Text File to Letrix File conversion Program. I hope youπwill find it useful.π}ππProgram QTextLetrix;ππ{$D-}ππUsesπ Crt, Dos;πππVarπ InFile,π TransFile : Text;π InFilenm,π TransFilenm : PathStr;π Letter, Ans : Char;π Printable,π Hebrew,π Niqud,π Roman : Set of Char;π Nkdm, Rom : Boolean;ππ{π "UpItsCase" is a Function that takes a sting of any length andπ sets all of the Characters in the String to upper case. It is handyπ For comparing Strings.π}ππFunction UpItsCase (SourceStr : PathStr) : PathStr;πVarπ i : Integer;πbeginπ For i := 1 to length(SourceStr) doπ SourceStr[i] := UpCase(SourceStr[i]);π UpItsCase := SourceStrπend; {Function UpItsCase}πππFunction Exist(fname : PathStr) : Boolean;πVarπ f : File;πbeginπ{$F-,I-}π Assign(f, fname);π Reset(f);π Close(f);π{$I+}π Exist := (IOResult = 0) and (fname <> '')πend; {Function exist}ππProcedure Help;πbeginπ Writeln;π Writeln ('QTLT (Version 1.0)');π Writeln ('Hebrew Text File Conversion');π Writeln ('Q-Text 2.10 File to Letrix(R) 3.6 Hebrew File');π Writeln;π Writeln;π Writeln ('QTLT converts Q-Text Files to Letrix Hebrew format Files.');π Writeln;π Writeln ('QTLT expects two parameters on the command line.');π Writeln ('The first parameter is the name of the File to convert,');π Writeln ('the second is the name of the new File.');π Writeln;π Writeln ('Example: QTLT HKVTL.HEB HKVTL.TXT');π Writeln;π Writeln ('If no parameters are found, QTLT will display this message.');π Writeln;π Halt;πend; {Procedure Help}ππ{π "ParseCommandLine" is a Procedure that checks if any data was inputπ at the Dos command line. If no data is there, then the "Help"π Procedure is executed and the Program is halted. Otherwise, theπ Mode strig Variable is set equal to the Text on the command line.π}ππProcedure ParseCommandLine;πbeginπ if (ParamCount = 0) or (ParamCount <> 2) thenπ Helpπ elseπ beginπ InFilenm := ParamStr(1);π InFilenm := UpItsCase(InFilenm);π TransFilenm := ParamStr(2);π TransFilenm := UpItsCase(TransFilenm);π end;πend; {Procedure ParseCommandLine}ππProcedure OpenFiles;πbeginπ {Open input/output Files}π If not exist(InFilenm) thenπ beginπ Writeln;π Writeln (InFilenm, ' not found');π Halt;π endπ Elseπ beginπ Assign (InFile, InFilenm);π Reset (InFile);π end;ππ If exist (TransFilenm) thenπ beginπ Writeln;π Writeln (TransFilenm, ' already exists!');π Write ('OverWrite it? (Y/N) > ');π Repeatπ Ans := ReadKey;π Ans := Upcase(Ans);π If Ans = 'N' then Halt;π Until Ans = 'Y';π end;ππ Assign (TransFile, TransFilenm);π ReWrite (TransFile);π Writeln;πend; {Procedure OpenFiles}ππππProcedure UseOfRoman;πbeginπ Writeln ('QTLT has detected Roman letters in the source Text.');π Writeln;π Writeln ('Letrix expects access to a Roman font to print these Characters');π Writeln ('otherwise Letrix will report an error condition of fail to perform.');π Writeln;π Writeln ('Sample Letrix load instruction: LX Hebrew Roman');π Writeln;π Writeln ('Be sure that these instances are enclosed within the proper');π Writeln ('Letrix font switch codes so they are not printed as Hebrew Character');π Writeln;πend; {Procedure UseOfRoman}ππProcedure Niqudim (Var Letter : Char);π{π Letrix Uses some standard Characters to represent niqudimπ While Q-Text does not.ππ This table ensures that certain Characters do not becomeπ niqudim when translated to Letrix by inserting the tokensπ which instruct the Letrix Program to use the alternateπ alphabet -- which by default is number 2.π}πbeginπ If Not Nkdm thenπ beginπ Writeln;π Writeln ('QTLT has detected Q-Text Characters which Letrix normaly Uses for');π Writeln ('has transcribed them to print as normal Characters.');π Writeln;π Writeln ('Letrix expects access a Roman font to print these Characters');π Writeln ('otherwise Letrix will report an error condition of fail to perfect');π Writeln;π Writeln ('Sample Letrix load instruction: LX Hebrew Roman');π Writeln;π Nkdm := True;π end; {if not Nkdm}ππ Case Letter ofππ '!' : Write (TransFile, '\2!\1');π '@' : Write (TransFile, '\2@\1');π '#' : Write (TransFile, '\2#\1');π '$' : Write (TransFile, '\2$\1');π '%' : Write (TransFile, '\2%\1');π '^' : Write (TransFile, '\2^\1');π '&' : Write (TransFile, '\2&\1');π '*' : Write (TransFile, '\2*\1');π '(' : Write (TransFile, '\2(\1');π ')' : Write (TransFile, '\2)\1');π '+' : Write (TransFile, '\2+\1');π '=' : Write (TransFile, '\2=\1');ππ end; {Case}ππend; {Procedure Nikudim}ππππProcedure QT_Table (Var Letter : Char);π{π This section reviews each QText letter and matches it With aπ Letrix equivalent where possibleπ}πbeginπ Case Letter ofππ #128 : Write (TransFile, 'a'); {Alef}π #129 : Write (TransFile, 'b'); {Bet }π #130 : Write (TransFile, 'g'); {Gimmel etc. }π #131 : Write (TransFile, 'd');π #132 : Write (TransFile, 'h');π #133 : Write (TransFile, 'w');π #134 : Write (TransFile, 'z');π #135 : Write (TransFile, 'H');π #136 : Write (TransFile, 'T');π #137 : Write (TransFile, 'y');π #138 : Write (TransFile, 'C');π #139 : Write (TransFile, 'c');π #140 : Write (TransFile, 'l');π #141 : Write (TransFile, 'M');π #142 : Write (TransFile, 'm');π #143 : Write (TransFile, 'N');π #144 : Write (TransFile, 'n');π #145 : Write (TransFile, 'S');π #146 : Write (TransFile, 'i');π #147 : Write (TransFile, 'F');π #148 : Write (TransFile, 'p');π #149 : Write (TransFile, 'X');π #150 : Write (TransFile, 'x');π #151 : Write (TransFile, 'k');π #152 : Write (TransFile, 'r');π #153 : Write (TransFile, 's');π #154 : Write (TransFile, 't');ππ end; {Case of}ππend; {Procedure QT_Table}πππProcedure DoIt;π{π Special commands requred by Letrix.π Proportional spacing off, line justification off,π double-strike on, pitch set to 12 Characters per inch.π}πbeginππ Writeln(transFile,'\p\j\D\#12');π {Transcription loop}π While not eof(InFile) doπ beginπ Read(InFile, Letter);ππ If (Letter in Printable) thenπ Write(TransFile, Letter);ππ If (Letter in Niqud) thenπ Niqudim(Letter);ππ If (Letter in Hebrew) thenπ QT_Table(Letter);ππ If (Letter in Roman) and (Rom = False) thenπ beginπ UseOfRoman;π Rom := True;π end; {Roman Detection}ππ end; {while}ππ {Close Files}ππ Close (TransFile);π Close (InFile);ππ {Final message}ππ Writeln;π Writeln;π Writeln('QTLT (Version 1.0)');π Writeln('Hebrew Text File Conversion');π Writeln('Q-Text 2.10 Files to Letrix(R) 3.6 Hebrew File');π Writeln;π Writeln ('Task Complete');π Writeln;π Writeln ('QTLT was written and released to the public domain by David Solly');π Writeln ('Bibliotheca Sagittarii, Ottawa, Canada (2 December 1992).');π Writeln;ππend; {Procedure DoIt}πππbeginππ {Initialize Variables}π Printable := [#10,#12,#13,#32..#127];π Roman := ['A'..'Z','a'..'z'];π Niqud := ['!','@','#','$','%','^','&','*','(',')','+','='];π Printable := Printable - Niqud;π Hebrew := [#128..#154];π Rom := False;π Nkdm := False;ππParseCommandLine;πOpenFiles;πDoIt;ππend.ππ{ππ Please find below the Turbo Pascal source code For the conversionπProgram For making Letrix Hebrew Files into Q-Text 2.10 Files. I couldπnot find a way to make this conversion Program convert embedded RomanπText without making it into a monster. If you have any suggestions, Iπwould be thankful to the input.ππ========================= Cut Here ========================π}ππProgram LetrixQText;ππ{$D-}ππUsesπ Crt, Dos;ππVarπ InFile,π TransFile : Text;π InFilenm,π TransFilenm : PathStr;π Letter, Ans : Char;π Printable,π HiASCII : Set of Char;ππ{π "UpItsCase" is a Function that takes a sting of any length andπ sets all of the Characters in the String to upper case. It is handyπ For comparing Strings.π}ππFunction UpItsCase (SourceStr : PathStr): PathStr;πVarπ i : Integer;πbeginπ For i := 1 to length(SourceStr) doπ SourceStr[i] := UpCase(SourceStr[i]);π UpItsCase := SourceStrπend; {Function UpItsCase}πππFunction Exist(fname : PathStr) : Boolean;πVarπ f : File;πbeginπ {$F-,I-}π Assign(f, fname);π Reset(f);π Close(f);π {$I+}π Exist := (IOResult = 0) and (fname <> '')πend; {Function exist}ππProcedure Help;πbeginπ Writeln;π Writeln ('LTQT (Version 1.0)');π Writeln ('Hebrew Text File Conversion');π Writeln ('Letrix(R) 3.6 File to Q-Text 2.10 File');π Writeln;π Writeln;π Writeln ('LTQT converts Letrix Hebrew format Files to Q-Text format Files.')π Writeln;π Writeln ('LTQT expects two parameters on the command line.');π Writeln ('The first parameter is the name of the File to convert,');π Writeln ('the second is the name of the new File.');π Writeln;π Writeln ('Example: LTQT HKVTL.TXT HKVTL.HEB');π Writeln;π Writeln ('If no parameters are found, LTQT will display this message.');π Writeln;π Halt;πend; {Procedure Help}ππ{π "ParseCommandLine" is a Procedure that checks if any data was inputπ at the Dos command line. If no data is there, then the "Help"π Procedure is executed and the Program is halted. Otherwise, theπ Mode strig Variable is set equal to the Text on the command line.π}πProcedure ParseCommandLine;πbeginπ if (ParamCount = 0) or (ParamCount <> 2) thenπ Helpπ elseπ beginπ InFilenm := ParamStr(1);π InFilenm := UpItsCase(InFilenm);π TransFilenm := ParamStr(2);π TransFilenm := UpItsCase(TransFilenm);π end;πend; {Procedure ParseCommandLine}ππProcedure OpenFiles;πbeginπ {Open input/output Files}π If not exist(InFilenm) thenπ beginπ Writeln;π Writeln (InFilenm, ' not found');π Halt;π endπ Elseπ beginπ Assign (InFile, InFilenm);π Reset (InFile);π end;ππ If exist (TransFilenm) thenπ beginπ Writeln;π Writeln (TransFilenm, ' already exists!');π Write ('OverWrite it? (Y/N) > ');π Repeatπ Ans := ReadKey;π Ans := Upcase(Ans);π If Ans = 'N' then Halt;π Until Ans = 'Y';π end;ππ Assign (TransFile, TransFilenm);π ReWrite (TransFile);π Writeln;ππend; {Procedure OpenFiles}ππππProcedure LT_Table (Var Letter : Char);π{π This section reviews each Letrix letter and matches it With aπ Q-Text equivalent where possibleπ}πbeginπ Case Letter ofππ 'a' : Write (TransFile, #128);π 'b', 'B','v' : Write (TransFile, #129); {Vet, Bet}π 'g' : Write (TransFile, #130);π 'd' : Write (TransFile, #131);π 'h' : Write (TransFile, #132);π 'V', 'o', 'u', 'w' : Write (TransFile, #133); {Vav, Holem male, Shuruq}π 'z' : Write (TransFile, #134);π 'H' : Write (TransFile, #135);π 'T' : Write (TransFile, #136);π 'y', 'e' : Write (TransFile, #137); {Yod}π 'C', 'Q', 'W' : Write (TransFile, #138); {Khaf-Sofit}π 'c', 'K' : Write (TransFile, #139); {Khaf, Kaf}π 'l' : Write (TransFile, #140);π 'M' : Write (TransFile, #141);π 'm' : Write (TransFile, #142);π 'N' : Write (TransFile, #143);π 'n' : Write (TransFile, #144);π 'S' : Write (TransFile, #145);π 'i' : Write (TransFile, #146);π 'F' : Write (TransFile, #147);π 'p', 'P', 'f' : Write (TransFile, #148); {Fe, Pe}π 'X' : Write (TransFile, #149);π 'x' : Write (TransFile, #150);π 'k' : Write (TransFile, #151);π 'r' : Write (TransFile, #152);π 's' : Write (TransFile, #153);π 't' : Write (TransFile, #154);π 'A' : Write (TransFile, '-');ππ {Niqudim and unused letters}ππ 'D','E', 'G', 'I', 'J', 'j', 'O', 'q', 'R', 'U', 'Y', 'Z' :π Write(TransFile, '');π elseπ Write(TransFile, Letter);ππ end; {Case of}ππend; {Procedure LT_Table}πππProcedure DoIt;πbeginπ {Transcription loop}π While not eof(InFile) doπ beginπ Read(InFile, Letter);ππ If (Letter in Printable) thenπ LT_Table(Letter);ππ If (Letter in HiASCII) thenπ Write(TransFile, Letter);π end; {while}ππ {Close Files}ππ Close (TransFile);π Close (InFile);ππ {Final message}ππ Writeln;π Writeln;π Writeln('LTQT Version 1.0');π Writeln('Hebrew Text File Conversion');π Writeln('Letrix(R) 3.6 File to Q-Text 2.10 File');π Writeln;π Writeln;π Writeln ('Letrix Hebrew File to Q-Text File conversion complete.');π Writeln;π Writeln('Special Note:');π Writeln;π Writeln ('Q-Text does not support either dagesh or niqudim (vowels).');π Writeln ('Letters containing a dagesh-qol are reduced to their simple form.');π Writeln ('Holam male and shuruq are transcribed as vav. Roman letters used');π Writeln ('to represent niqudim are ignored. All other symbols are transcribed'π Writeln ('without change.');π Writeln;π Writeln ('There is no foreign language check -- Anything that can be transcribeπ Writeln ('into Hebrew Characters will be.');π Writeln;π Writeln ('LTQT was written and released to the public domain by David Solly');π Writeln ('Bibliotheca Sagittarii, Ottawa, Canada (8 December 1992).');π Writeln;ππend; {Procedure DoIt}πππbeginπ {Initialize Variables}π Printable := [#10,#12,#13,#32..#127];π HiASCII := [#128..#154];ππ ParseCommandLine;π OpenFiles;π DoIt;πend.ππ 7 05-28-9313:51ALL SWAG SUPPORT TEAM LONGJUMP.PAS IMPORT 22 Unit LongJump;ππ{ This Unit permits a long jump from deeply nested Procedures/Functions back }π{ to a predetermined starting point. }ππ{ Whilst the purists may shudder at such a practice there are times when such}π{ an ability can be exceedingly useful. An example of such a time is in a }π{ BBS Program when the carrier may be lost unexpectedly whilst a user is on }π{ line and the requirement is to "back out" to the initialisation reoutines }π{ at the start of the Program. }ππ{ to use the facility, it is required that a call be made to the SetJump }π{ Function at the point to where you wish the execution to resume after a }π{ long jump. When the time comes to return to that point call FarJump. }ππ{ if you are an inexperienced Programmer, I do not recommend that this Unit }π{ be used For other than experimentation. Usually there are better ways to }π{ achieve what you want to do by proper planning and structuring. It is }π{ rare to find a well written Program that will need such and ability. }ππInterfaceππConstπ normal = -1; { return was not from a LongJump call }πTypeπ jumpType = Record { the data need For a return jump }π bp,sp,cs,ip : Word;π end;ππFunction SetJump(Var JumpData : jumpType): Integer;πProcedure FarJump(JumpData : jumpType; IDInfo : Integer);ππImplementationππTypeπ WordPtr = ^Word;ππFunction SetJump(Var JumpData : jumpType): Integer;π begin { store the return address (the old bp register) }π JumpData.bp := WordPtr(ptr(SSeg,SPtr+2))^;π JumpData.ip := WordPtr(ptr(SSeg,SPtr+4))^;π JumpData.cs := WordPtr(ptr(SSeg,SPtr+6))^;π JumpData.SP := SPtr;π SetJump := normal; { show that this is not a FarJump call }π end; { SetJump }ππProcedure FarJump(JumpData : jumpType; IDInfo : Integer );π beginπ { change the return address of the calling routine of the stack so that }π { a return can be made to the caller of SetJump }π { Use IDInfo as an identifier of the routine the jump occurred from }π WordPtr(ptr(SSeg,JumpData.SP))^ := JumpData.bp;π WordPtr(ptr(SSeg,JumpData.SP+2))^ := JumpData.ip;π WordPtr(ptr(SSeg,JumpData.SP+4))^ := JumpData.cs;π Inline($8b/$46/$06); { mov ax,[bp+6] }π Inline($8b/$ae/$fa/$ff); { mov bp,[bp-6] }π end; { FarJump }ππend. { LongJump }πππ 8 05-28-9313:51ALL SWAG SUPPORT TEAM MAKEDATA.PAS IMPORT 7 {> I need about 10 megs of raw data and am looking For info-pascal archives.π> Do they exist? ...and if so could someone please direct me to where I canπI wish everyone made such easy requests to fulfil. Try the followingπProgram. With minor changes, it will supply you With almost any amountπof data For which you could ask.π}πProgram GenerateData;πUsesπ Crt;πConstπ DataWanted = 3.0E5;πVarπ Data : File of Byte;π Count : LongInt;π Garbage : Byte;πbeginπ Assign(Data, 'Data.1MB');π ReWrite(Data);π Count := 0;π Garbage := 1;π For Count := 1 to Round(DataWanted) doπ beginπ Write(Data, garbage); (* smile *)π GotoXY(1,1);π Write(Count);π Inc(Count);π end;π Close(Data)πend.π 9 05-28-9313:51ALL SWAG SUPPORT TEAM MAZE.PAS IMPORT 14 {πSEAN PALMERππ> Hello there.. I was just wondering.. Since I am completely 'C'π> illiterate, could someone please make an effort and convert theπ> following code in Pascal For me? (Its supposedly makes a solveableπ> maze every time, Cool)ππ{originally by jallen@ic.sunysb.edu}π{Turbo Pascal conversion by Sean Palmer from original C}ππConstπ h = 23; {height}π w = 79; {width}ππConstπ b : Array [0..3] of Integer = (-w, w, 1, -1);π { incs For up, down, right, left }ππVarπ a : Array [0..w * h - 1] of Boolean; { the maze (False = wall) }ππProcedure m(p : Integer);πVarπ i, d : Byte;πbeginπ a[p] := True; {make a path}π Repeatπ d := 0; {check For allowable directions}π if (p > 2 * w) and not (a[p - w - w]) thenπ inc(d, 1); {up}π if (p < w * (h - 2)) and not (a[p + w + w]) thenπ inc(d, 2); {down}π if (p mod w <> w - 2) and not (a[p + 2]) thenπ inc(d, 4); {right}π if (p mod w <> 1) and not (a[p - 2]) thenπ inc(d, 8); {left}π if d <> 0 thenπ beginπ Repeat {choose a direction that's legal}π i := random(4);π Until Boolean(d and(1 shl i));ππ a[p + b[i]] := True; {make a path}π m(p + 2 * b[i]); {recurse}π end;π Until d = 0; {Until stuck}πend;ππVarπ i : Integer;ππbeginπ randomize;π fillChar(a, sizeof(a), False);π m(succ(w)); {start at upper left}π For i := 0 to pred(w * h) doπ begin {draw}π if i mod w = 0 thenπ Writeln;π if a[i] thenπ Write(' ')π elseπ Write('█');π end;πend.π 10 05-28-9313:51ALL SWAG SUPPORT TEAM MISCFUNC.PAS IMPORT 52 Unit MiscFunc;ππ{ MiscFunc version 1.0 Scott D. Ramsay }ππ{ This is my misc. Function Unit. Some of the Functions have }π{ nothing to do With games design but, my Units use it so ... }π{ MiscFunc.pas is free. Go crazy. }π{ I've been writing comments to these Units all night. Since you }π{ have the source to this, I'll let you figure out what each one }π{ does. }ππInterfaceππFunction strint(s:String):LongInt;πFunction intstr(l:LongInt):String;πFunction ups(s:String):String;πFunction st(h:LongInt):String;πFunction Compare(s1,s2:String):Boolean;πFunction dtcmp(Var s1,s2;size:Word):Boolean;πFunction lz(i,w:LongInt):String;πFunction vl(h:String):LongInt;πFunction spaces(h:Integer):String;πFunction repstr(h:Integer;ch:Char):String;πFunction anything(s:String):Boolean;πFunction exist(f:String):Boolean;πFunction errmsg(n:Integer):String;πFunction turboerror(errorcode:Integer) : String;πProcedure funpad(Var s:String);πProcedure unpad(Var s:String);πProcedure munpad(Var s:String;b:Byte);πFunction fpad(s:String;h:Integer):String;πProcedure pad(Var s:String;h:Integer);πProcedure fix(Var s:String;h:String);πProcedure fixh(Var s:String);πFunction range(x,y,x1,y1,x2,y2:Integer) : Boolean;πFunction between(x,x1,x2:Integer):Boolean;ππImplementationπππFunction range(x,y,x1,y1,x2,y2:Integer) : Boolean;π{ returns True if (x,y) is in the rectangular region (x1,y1,x2,y2) }πbeginπ range := ((x>=x1) and (x<=x2) and (y>=y1) and (y<=y2));πend;πππProcedure fix(Var s:String;h:String);πbeginπ if pos('.',s)=0π then s := s+h;πend;πππProcedure fixh(Var s:String);πVarπ d : Integer;πbeginπ For d := 1 to length(s) doπ if s[d]<#32π then s[d] := ' ';π For d := length(s)+1 to 255 doπ s[d] := ' ';πend;πππFunction strint(s:String):LongInt;πVarπ l : LongInt;πbeginπ move(s[1],l,sizeof(l));π strint := l;πend;πππFunction intstr(l:LongInt):String;πVarπ s : String;πbeginπ move(l,s[1],sizeof(l));π s[0] := #4;π intstr := s;πend;πππFunction ups(s:String):String;πVarπ d : Integer;πbeginπ For d := 1 to length(s) doπ s[d] := upCase(s[d]);π ups := s;πend;πππFunction st(h:LongInt):String;πVarπ s : String;πbeginπ str(h,s);π st := s;πend;πππFunction Compare(s1,s2:String):Boolean;πVarπ d : Byte;π e : Boolean;πbeginπ e := True;π For d := 1 to length(s1) doπ if upCase(s1[d])<>upCase(s2[d])π then e := False;π Compare := e;πend;πππFunction dtcmp(Var s1,s2;size:Word):Boolean;πVarπ d : Word;π e : Boolean;πbeginπ e := True;π d := size;π While (d>0) and e doπ beginπ dec(d);π e := (mem[seg(s1):ofs(s1)+d]=mem[seg(s2):ofs(s2)+d]);π end;π dtcmp := e;πend;πππFunction lz(i,w:LongInt):String;πVarπ d : LongInt;π s : String;πbeginπ str(i,s);π For d := length(s) to w-1 doπ s := concat('0',s);π lz := s;πend;πππFunction vl(h:String):LongInt;πVarπ d : LongInt;π e : Integer;πbeginπ val(h,d,e);π vl := d;πend;πππFunction spaces(h:Integer):String;πVarπ s : String;πbeginπ s := '';π While h>0 doπ beginπ dec(h);π s := concat(s,' ');π end;π spaces := s;πend;πππFunction repstr(h:Integer;ch:Char):String;πVarπ s : String;πbeginπ s := '';π While h>0 doπ beginπ dec(h);π s := s+ch;π end;π repstr := s;πend;πππFunction anything(s:String):Boolean;πVarπ d : Integer;π h : Boolean;πbeginπ if length(s)=0π thenπ beginπ anything := False;π Exit;π end;π h := False;π For d := 1 to length(s) doπ if s[d]>#32π then h := True;π anything := h;πend;πππFunction exist(f:String):Boolean;πVarπ fil : File;πbeginπ if f=''π thenπ beginπ exist := False;π Exit;π end;π assign(fil,f);π {$i- }π reset(fil);π close(fil);π {$i+ }π exist := (ioresult=0);πend;πππFunction errmsg(n:Integer):String;πbeginπ Case n ofπ -1 : errmsg := '';π -2 : errmsg := 'Error reading data File';π -3 : errmsg := '';π -4 : errmsg := 'equal current data File name';π 150 : errmsg := 'Disk is Write protected';π 152 : errmsg := 'Drive is not ready';π 156 : errmsg := 'Disk seek error';π 158 : errmsg := 'Sector not found';π 159 : errmsg := 'Out of Paper';π 160 : errmsg := 'Error writing to Printer';π 1000 : errmsg := 'Record too large';π 1001 : errmsg := 'Record too small';π 1002 : errmsg := 'Key too large';π 1003 : errmsg := 'Record size mismatch';π 1004 : errmsg := 'Key size mismatch';π 1005 : errmsg := 'Memory overflow';π else errmsg := 'Error result #'+st(n);π end;πend;πππFunction turboerror(errorcode:Integer) : String;πbeginπ Case errorcode ofπ 1: turboerror := 'Invalid Dos Function code';π 2: turboerror := 'File not found';π 3: turboerror := 'Path not found';π 4: turboerror := 'too many open Files';π 5: turboerror := 'File access denied';π 6: turboerror := 'Invalid File handle';π 8: turboerror := 'not enough memory';π 12: turboerror := 'Invalid File access code';π 15: turboerror := 'Invalid drive number';π 16: turboerror := 'Cannot remove current directory';π 17: turboerror := 'Cannot rename across drives';π 100: turboerror := 'Disk read error';π 101: turboerror := 'Disk Write error';π 102: turboerror := 'File not assigned';π 103: turboerror := 'File not open';π 104: turboerror := 'File not open For input';π 105: turboerror := 'File not open For output';π 106: turboerror := 'Invalid numeric Format';π 200: turboerror := 'division by zero';π 201: turboerror := 'Range check error';π 202: turboerror := 'Stack overflow error';π 203: turboerror := 'Heap overflow error';π 204: turboerror := 'Invalid Pointer operation';π else turboerror := errmsg(errorcode);π end;πend;πππProcedure funpad(Var s:String);πbeginπ While s[1]=' ' doπ delete(s,1,1);πend;πππProcedure unpad(Var s:String);πbeginπ While (length(s)>0) and (s[length(s)]<=' ') doπ delete(s,length(s),1);πend;πππProcedure munpad(Var s:String;b:Byte);πbeginπ s[0] := Char(b);π While (length(s)>0) and (s[length(s)]<=' ') doπ delete(s,length(s),1);πend;πππFunction fpad(s:String;h:Integer):String;πbeginπ While length(s)<h doπ s := concat(s,' ');π fpad := s;πend;πππProcedure pad(Var s:String;h:Integer);πbeginπ While length(s)<h doπ s := concat(s,' ');πend;πππFunction between(x,x1,x2:Integer):Boolean;πbeginπ between := ((x>=x1) and (x<=x2));πend;πππend. 11 05-28-9313:51ALL SWAG SUPPORT TEAM PATCHEXE.PAS IMPORT 22 {π>If this cannot be done, then hhow can one include a pcx directly insideπ>the compiled File???ππ There's a trick to do that :π Suppose your Program is called PROG.EXE and your PCX File IMAGE.PCXππ After each compile of PROG.EXE, do :π COPY /B PROG.EXE+IMAGE.PCXππ Then, when you want to display the PCX, open the EXE File, read it'sπ header :π}ππFunction GetExeSize(ExeName:String; Var TotSize,Expect:LongInt):Boolean;π{ returns True if EXE is already bind }πTypeπ ExeHeaderRec = Record {Information describing EXE File}π Signature : Word; {EXE File signature}π LengthRem : Word; {Number of Bytes in last page of EXE imageπ LengthPages : Word; {Number of 512 Byte pages in EXE image}π NumReloc : Word; {Number of relocation items}π HeaderSize : Word; {Number of paraGraphs in EXE header}π MinHeap,MaxHeap : Word; {ParaGraphs to keep beyond end of image}π StackSeg,StackPtr : Word; {Initial SS:SP, StackSeg relative to imageπ CheckSum : Word; {EXE File check sum, not used}π IpInit, CodeSeg : Word; {Initial CS:IP, CodeSeg relative to imageπ RelocOfs : Word; {Bytes into EXE For first relocation item}π OverlayNum : Word; {Overlay number, not used here}π end;ππVarπ ExeF : File;π ExeHeader : ExeHeaderRec;π ExeValue : LongInt;π count : Word;ππbeginπ TotSize:=0; Expect:=0;π Assign(ExeF,ExeName); Reset(ExeF,1);π if IoResult=0 thenπ beginπ TotSize:=FileSize(ExeF);π BlockRead(ExeF,ExeHeader,SizeOf(ExeHeaderRec),Count);π With ExeHeader doπ if Signature=$5A4D thenπ beginπ if LengthRem=0 thenπ ExeValue:=LongInt(LengthPages) shl 9π elseπ ExeValue:=(LongInt(Pred(LengthPages)) shl 9)π Expect:=ExeValue;π end;π end;π Close(ExeF);π GetExeSize:=(TotSize<>Expect);πend;ππ{π If GetExeSize returns True, your PCX has been placed at the end of theπ EXE (you did not forget :)) and all you have to do next is skip theπ Program itself : Seek(ExeF,Expect);ππ Then starts your PCX. If you know in advance the sizes of the PCXπ File, you can place any data you want (including lots of PCX) at theπ end of your EXE.ππ This example is taken from a Unit I wrote a long time ago (was calledπ Caravane) and it worked very well. I accessed the end of my exe Fileπ like a normal Typed File. Quite funny but I do not use this anymore.π Note that you can LzExe or Pklite the EXE part (not the PCX one). Youπ can DIET both parts With the resident version.ππ I hope the Function GetExeSize is not copyrighted since it is much tooπ commented to be one of my work :)π 12 05-28-9313:51ALL SWAG SUPPORT TEAM REBOOT1.PAS IMPORT 9 { Subject: How to reboot With TP7.0 ??? }πVarπ hook : Word Absolute $0040:$0072;ππProcedure Reboot(Cold : Boolean); Far;πbeginπ if (Cold = True) thenπ hook := $0000π elseπ hook := $1234;ππ ExitProc := ptr($FFFF,$0000);πend;πππ{πP.S. Note that it does not require any Units to compile. Thoughπdepending on your Implementation, you may need to call HALT toπtrip the Exit code (which caUses a reboot).π}ππProgram reset;πUsesπ Dos;πVarπ regs : Registers;πbeginπ intr(25,regs);πend.ππ{ Yeah but it is easier to do it in Inline Asmπeg:π}πProgram reset;πbeginπ Asmπ INT 19h; {19h = 25 decimal}π end;πend.ππ{πOne Word about this interupt is that it is the fastest rebootπI know of but some memory managers, eg QEMM 6.03 don't like it,πIt will seriously hang Windows if called from a Dos Shell,πMicrosoft Mouse Driver 8.20 doesn't seem to like being runπafter you call int 19h and it was resident.πOther than that it works like a gem!π}π 13 05-28-9313:51ALL SWAG SUPPORT TEAM REBOOT2.PAS IMPORT 7 {πKARIM SULTANππBelieve it or not, Int 19h is not he way to go. It will stimulate a warmπboot, but it is not very safe. It doesn't do some of the shutdown workπnecessary For some applications, and the preferred method is to set the Wordπat location 40:72 and to jump to $FFFF:0.πHere are my Procedures For doing reboots from a Program:π}πProcedure ColdBoot; Assembler;πAsmπ Xor AX, AXπ Mov ES, AXπ Mov Word PTR ES:[472h],0000h {This is not a WARM boot}π Mov AX, 0F000hπ Push AXπ Mov AX, 0FFF0hπ Push AXπ Retfπend;ππProcedure WarmBoot; Assembler;πAsmπ Xor AX, AXπ Mov ES, AXπ Mov Word PTR ES:[472h],1234h {This is not a COLD boot}π Mov AX, 0F000hπ Push AXπ Mov AX, 0FFF0hπ Push AXπ Retfπend;π 14 05-28-9313:51ALL SWAG SUPPORT TEAM REBOOT3.PAS IMPORT 4 {πREYNIR STEFANSSONππFor anyone wondering how to reboot a PClone from Within Turbo Pascal:πThe Inline code is a far jump to the restart vector at $FFFF:0.π}ππProcedure ColdStart;πbeginπ MemW[$40:$72] := 0;π Inline($EA/0/0/$FF/$FF);πend;ππProcedure WarmStart;πbeginπ MemW[$40:$72] := $1234;π Inline($EA/0/0/$FF/$FF);πend;ππ 15 05-28-9313:51ALL SWAG SUPPORT TEAM SUNDRY.PAS IMPORT 99 Unit sundry;ππInterfaceππUsesπ Dos,π sCrt,π Strings;ππTypeπ LongWds = Recordπ loWord,π hiWord : Word;π end;π ica_rec = Recordπ Case Integer ofπ 0: (Bytes : Array[0..15] of Byte);π 1: (Words : Array[0..7] of Word);π 2: (Integers: Array[0..7] of Integer);π 3: (strg : String[15]);π 4: (longs : Array[0..3] of LongInt);π 5: (dummy : String[13]; chksum: Integer);π 6: (mix : Byte; wds : Word; lng : LongInt);π end;π{-This simply creates a Variant Record which is mapped to 0000:04F0π which is the intra-applications communications area in the bios areaπ of memory. A Program may make use of any of the 16 Bytes in this areaπ and be assured that Dos and the bios will not interfere With it. Thisπ means that it can be effectively used to pass values/inFormationπ between different Programs. It can conceivably be used to storeπ inFormation from an application, then terminate from that application,π run several other Programs, and then have another Program use theπ stored inFormation. As the area can be used by any Program, it is wiseπ to incorporate a checksum to ensure that the intermediate applicationsπ have not altered any values. It is of most use when executing childπ processes or passing values between related Programs that are runπ consecutively.}ππ IOproc = Procedure(derror:Byte; msg : String);ππConstπ ValidChars : String[40] = ' ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-'+#39;π HexChars : Array[0..15] of Char = '0123456789ABCDEF';ππVarπ ica : ica_rec Absolute $0000:$04f0;π FilePosition : LongInt;π(* OldRecSize : Word; *)π TempStr : String;ππProcedure CheckIO(Error_action : IOproc; msg : String);ππFunction CompressStr(Var n): String;π {-Will Compress 3 alpha-numeric Bytes into 2 Bytes}ππFunction DeCompress(Var s): String;π {-DeCompresses a String Compressed by CompressStr}ππFunction NumbofElements(Var s; size : Word): Word;π {-returns the number of active elements in a set}ππFunction PrinterStatus : Byte;π {-Gets the Printer status}ππFunction PrinterReady(Var b : Byte): Boolean;ππFunction TestBbit(n,b: Byte): Boolean;πFunction TestWbit(Var n; b: Byte): Boolean;πFunction TestLbit(n: LongInt; b: Byte): Boolean;ππProcedure SetBbit(Var n: Byte; b: Byte);πProcedure SetWbit(Var n; b: Byte);πProcedure SetLbit(Var n: LongInt; b: Byte);ππProcedure ResetBbit(Var n: Byte; b: Byte);πProcedure ResetWbit(Var n; b: Byte);πProcedure ResetLbit(Var n: LongInt; b: Byte);ππFunction right(Var s; n : Byte): String;πFunction left(Var s; n : Byte): String;πFunction shleft(Var s; n : Byte): String;πFunction nExtStr(Var s1; s2 : String; n : Byte): String;πProcedure WriteAtCr(st: String; col,row: Byte);πProcedure WriteLnAtCr(st: String; col,row: Byte);πProcedure WriteLNCenter(st: String; width: Byte);πProcedure WriteCenter(st: String; width: Byte);πProcedure GotoCR(col,row: Byte);ππ {-These Functions and Procedures Unit provides the means to do randomπ access reads on Text Files. }ππFunction Exist(fn : String) : Boolean;ππFunction Asc2Str(Var s; max: Byte): String;ππProcedure DisableBlink(State:Boolean);ππFunction Byte2Hex(numb : Byte) : String;ππFunction Numb2Hex(Var numb) : String;ππFunction Long2Hex(long : LongInt): String;ππFunction Hex2Byte(HexStr : String) : Byte;ππFunction Hex2Word(HexStr : String) : Word;ππFunction Hex2Integer(HexStr : String) : Integer;ππFunction Hex2Long(HexStr : String) : LongInt;ππ{======================================================================}πππImplementationππProcedure CheckIO(error_action : IOproc;msg : String);π Var c : Word;π beginπ c := Ioresult;π if c <> 0 then error_action(c,msg);π end;πππ{$F+}πProcedure ReportError(c : Byte; st : String);π beginπ Writeln('I/O Error ',c);π Writeln(st);π halt(c);π end;π{$F-}ππFunction StUpCase(Str : String) : String;πVarπ Count : Integer;πbeginπ For Count := 1 to Length(Str) doπ Str[Count] := UpCase(Str[Count]);π StUpCase := Str;πend;ππππFunction CompressStr(Var n): String;π Varπ S : String Absolute n;π InStr : String;π len : Byte Absolute InStr;π Compstr: Recordπ Case Byte ofπ 0: (Outlen : Byte;π OutArray: Array[0..84] of Word);π 1: (Out : String[170]);π end;π temp,π x,π count : Word;π beginπ FillChar(InStr,256,32);π InStr := S;π len := (len + 2) div 3 * 3;π FillChar(CompStr.Out,171,0);π InStr := StUpCase(InStr);π x := 1; count := 0;π While x <= len do beginπ temp := pos(InStr[x+2],ValidChars);π inc(temp,pos(InStr[x+1],ValidChars) * 40);π inc(temp,pos(InStr[x],ValidChars) * 1600);π inc(x,3);π CompStr.OutArray[count] := temp;π inc(count);π end;π CompStr.Outlen := count shl 1;π CompressStr := CompStr.Out;π end; {-CompressStr}ππFunction DeCompress(Var s): String;π Varπ CompStr : Recordπ clen : Byte;π arry : Array[0..84] of Word;π end Absolute s;π x,π count,π temp : Word;π beginπ With CompStr do beginπ DeCompress[0] := Char((clen shr 1) * 3);π x := 0; count := 1;π While x <= clen shr 1 do beginπ temp := arry[x] div 1600;π dec(arry[x],temp*1600);π DeCompress[count] := ValidChars[temp];π temp := arry[x] div 40;π dec(arry[x],temp*40);π DeCompress[count+1] := ValidChars[temp];π temp := arry[x];π DeCompress[count+2] := ValidChars[temp];π inc(count,3);π inc(x);π end;π end;π end;ππFunction NumbofElements(Var s; size : Word): Word;π {-The Variable s can be any set Type and size is the Sizeof(s)}π Varπ TheSet : Array[1..32] of Byte Absolute s;π count,x,y : Word;π beginπ count := 0;π For x := 1 to size doπ For y := 0 to 7 doπ inc(count, 1 and (TheSet[x] shr y));π NumbofElements := count;π end;ππFunction PrinterStatus : Byte;π Var regs : Registers; {-from the Dos Unit }π beginπ With regs do beginπ dx := 0; {-The Printer number LPT2 = 1 }π ax := $0200; {-The Function code For service wanted }π intr($17,regs); {-$17= ROM bios int to return Printer status}π PrinterStatus := ah;{-Bit 0 set = timed out }π end; { 1 = unused }π end; { 2 = unused }π { 3 = I/O error }π { 4 = Printer selected }π { 5 = out of paper }π { 6 = acknowledge }π { 7 = Printer not busy }ππFunction PrinterReady(Var b : Byte): Boolean;π beginπ b := PrinterStatus;π PrinterReady := (b = $90) {-This may Vary between Printers}π end;ππFunction TestBbit(n,b: Byte): Boolean;π beginπ TestBbit := odd(n shr b);π end;ππFunction TestWbit(Var n; b: Byte): Boolean;π Var t: Word Absolute n;π beginπ if b < 16 thenπ TestWbit := odd(t shr b);π end;ππFunction TestLbit(n: LongInt; b: Byte): Boolean;π beginπ if b < 32 thenπ TestLbit := odd(n shr b);π end;ππProcedure SetBbit(Var n: Byte; b: Byte);π beginπ if b < 8 thenπ n := n or (1 shl b);π end;ππProcedure SetWbit(Var n; b: Byte);π Var t : Word Absolute n; {-this allows either a Word or Integer}π beginπ if b < 16 thenπ t := t or (1 shl b);π end;ππProcedure SetLbit(Var n: LongInt; b: Byte);π beginπ if b < 32 thenπ n := n or (LongInt(1) shl b);π end;ππProcedure ResetBbit(Var n: Byte; b: Byte);π beginπ if b < 8 thenπ n := n and not (1 shl b);π end;ππProcedure ResetWbit(Var n; b: Byte);π Var t: Word Absolute n;π beginπ if b < 16 thenπ t := t and not (1 shl b);π end;ππProcedure ResetLbit(Var n: LongInt; b: Byte);π beginπ if b < 32 thenπ n := n and not (LongInt(1) shl b);π end;ππFunction right(Var s; n : Byte): String;π Varπ st : String Absolute s;π len: Byte Absolute s;π beginπ if n >= len then right := st elseπ right := copy(st,len+1-n,n);π end;ππFunction shleft(Var s; n : Byte): String;π Varπ st : String Absolute s;π stlen: Byte Absolute s;π temp : String;π len : Byte Absolute temp;π beginπ if n < stlen then beginπ move(st[n+1],temp[1],255);π len := stlen - n;π shleft := temp;π end;π end;ππFunction left(Var s; n : Byte): String;π Varπ st : String Absolute s;π temp: String;π len : Byte Absolute temp;π beginπ temp := st;π if n < len then len := n;π left := temp;π end;ππFunction nExtStr(Var s1;s2 : String; n : Byte): String;π Varπ main : String Absolute s1;π second : String Absolute s2;π len : Byte Absolute s2;π beginπ nExtStr := copy(main,pos(second,main)+len,n);π end;ππProcedure WriteAtCr(st: String; col,row: Byte);π beginπ GotoXY(col,row);π Write(st);π end;πππProcedure WriteLnAtCr(st: String; col,row: Byte);π beginπ GotoXY(col,row);π Writeln(st);π end;ππFunction Charstr(ch : Char; by : Byte) : String;πVarπ Str : String;π Count : Integer;πbeginπ Str := '';π For Count := 1 to by doπ Str := Str + ch;π CharStr := Str;πend;πππProcedure WriteLnCenter(st: String; width: Byte);π beginπ TempStr := CharStr(' ',(width div 2) - succ((length(st) div 2)));π st := TempStr + st;π Writeln(st);π end;ππProcedure WriteCenter(st: String; width: Byte);π beginπ TempStr := CharStr(' ',(width div 2)-succ((length(st) div 2)));π st := TempStr + st;π Write(st);π end;ππProcedure GotoCR(col,row: Byte);π beginπ GotoXY(col,row);π end;ππFunction Exist(fn : String): Boolean;π Varπ f : File;π OldMode : Byte;π beginπ OldMode := FileMode;π FileMode:= 0;π assign(f,fn);π {$I-} reset(f,1); {$I+}π if Ioresult = 0 then beginπ close(f);π Exist := True;π endπ elseπ Exist := False;π FileMode:= OldMode;π end; {-Exist}ππFunction Asc2Str(Var s; max: Byte): String;π Var stArray : Array[0..255] of Byte Absolute s;π st : String;π len : Byte Absolute st;π beginπ move(stArray[0],st[1],255);π len := max;π len := (max + Word(1)) * ord(pos(#0,st) = 0) + pos(#0,st)-1;π Asc2Str := st;π end;πππProcedure DisableBlink(state : Boolean);π { DisableBlink(True) allows use of upper eight colors as background }π { colours. DisableBlink(False) restores the normal mode and should }π { be called beFore Program Exit }πVarπ regs : Registers;πbeginπ With regs doπ beginπ ax := $1003;π bl := ord(not(state));π end;π intr($10,regs);πend; { DisableBlink }ππFunction Byte2Hex(numb : Byte) : String;π beginπ Byte2Hex[0] := #2;π Byte2Hex[1] := HexChars[numb shr 4];π Byte2Hex[2] := HexChars[numb and 15];π end;ππFunction Numb2Hex(Var numb) : String;π { converts an Integer or a Word to a String. Using an unTypedπ argument makes this possible. }π Var n : Word Absolute numb;π beginπ Numb2Hex := Byte2Hex(hi(n))+Byte2Hex(lo(n));π end;ππFunction Long2Hex(long : LongInt): String;π beginπ With LongWds(long) do { Type casting makes the split up easy}π Long2Hex := Numb2Hex(hiWord) + Numb2Hex(loWord);π end;ππFunction Hex2Byte(HexStr : String) : Byte;π beginπ Hex2Byte := pos(UpCase(HexStr[2]),HexChars)-1 +π ((pos(UpCase(HexStr[1]),HexChars))-1) shl 4 { * 16}π end;ππFunction Hex2Word(HexStr : String) : Word;π { This requires that the String passed is a True hex String of 4π Chars and not in a Format like $FDE0 }π beginπ Hex2Word := pos(UpCase(HexStr[4]),HexChars)-1 +π ((pos(UpCase(HexStr[3]),HexChars))-1) shl 4 + { * 16}π ((pos(UpCase(HexStr[2]),HexChars))-1) shl 8 + { * 256}π ((pos(UpCase(HexStr[1]),HexChars))-1) shl 12; { *4096}π end;ππFunction Hex2Integer(HexStr : String) : Integer;π beginπ Hex2Integer := Integer(Hex2Word(HexStr));π end;ππFunction Hex2Long(HexStr : String) : LongInt;π Var Long : LongWds;π beginπ Long.hiWord := Hex2Word(copy(HexStr,1,4));π Long.loWord := Hex2Word(copy(HexStr,5,4));π Hex2Long := LongInt(Long);π end;ππbeginπ FilePosition := 0;πend.π 16 05-28-9313:51ALL SWAG SUPPORT TEAM TPASM.PAS IMPORT 79 { Ok here it is.. I have disasembled the following TP Program toπshow you the inner workings of TP (well at least 6.0). TheπFolloing Program was Compiled in the IDE With RANGE, I/O, STACKπchecking turned off. Look at the code close and see if you canπfind a nasty little bug in it beFore I show you the Asm that TPπCreated on disk.π}ππProgram TstFiles;ππType MyRec = Recordπ LInt : LongInt;π Hi : Word;π Lo : Word;π B1 : Byte;π B2 : Byte;π B3 : Byte;π B4 : Byte;π end; {Record Size 12 Bytes}ππConst MaxRecs = 100;πππVar MyTypedFile : File of MyRec;π MyUnTypedFile : File;ππ Rec : MyRec;π RecCnt : Word;πππProcedure FillRec (RecSeed : LongInt);ππ beginπ Rec.Lint := RecSeed;π Rec.Hi := Hi (Rec.Lint);π Rec.Lo := Lo (Rec.Lint);π Rec.B1 := Lo (Rec.Lo);π Rec.B2 := Hi (Rec.Lo);π Rec.B3 := Lo (Rec.Hi);π Rec.B4 := Hi (Rec.Hi);π end;πππππbeginπAssign (MyTypedFile, 'Type.Dat');πAssign (MyUnTypedFile, 'UnTyped.Dat');πReWrite (MyTypedFile);πReWrite (MyUnTypedFile);ππFor RecCnt := 1 to MaxRecs doπ beginπ FillRec (RecCnt);ππ Write (MyTypedFile , Rec);π{ Write (MyUnTypedFile, Rec);} {Illegal can't do this}ππ FillRec (RecCnt + $FFFF);ππ{ BlockWrite (MyTypedFile, Rec, 1);} {Illegal Can't do this eather}ππ BlockWrite (MyUnTypedFile, Rec, Sizeof (MyRec));π end;πππend.πππThe Asm Break down is in the next two messages...ππTSTFileS.38: beginπ cs:0051 9A0000262D call 2D26:0000 <-------TP Start Up Codeπ cs:0056 55 push bpπ cs:0057 89E5 mov bp,spπTSTFileS.39: Assign (MyTypedFile, 'Type.Dat');π cs:0059 BF4400 mov di,0044π cs:005C 1E push dsπ cs:005D 57 push diπ cs:005E BF3C00 mov di,003Cπ cs:0061 0E push csπ cs:0062 57 push diπ cs:0063 9AC004262D call 2D26:04C0 <-------TP's Routine to setπ up File Records.πTSTFileS.40: Assign (MyUnTypedFile, 'UnTyped.Dat');π cs:0068 BFC400 mov di,00C4π cs:006B 1E push dsπ cs:006C 57 push diπ cs:006D BF4500 mov di,0045π cs:0070 0E push csπ cs:0071 57 push diπ cs:0072 9AC004262D call 2D26:04C0 <-------TP's Routine to setπ up File Records.πTSTFileS.41: ReWrite (MyTypedFile);π cs:0077 BF4400 mov di,0044π cs:007A 1E push dsπ cs:007B 57 push diπ cs:007C B80C00 mov ax,000Cπ cs:007F 50 push axπ cs:0080 9AF704262D call 2D26:04F7 <-------TP's Routine toπ Create File.πTSTFileS.42: ReWrite (MyUnTypedFile);π cs:0085 BFC400 mov di,00C4π cs:0088 1E push dsπ cs:0089 57 push diπ cs:008A B88000 mov ax,0080π cs:008D 50 push axπ cs:008E 9AF704262D call 2D26:04F7 <-------TP's Routine toπ Create File.πTSTFileS.44: For RecCnt := 1 to MaxRecs doπ cs:0093 C70650010100 mov Word ptr [TSTFileS.RECCNT],00π *** Clear the loop counter For first loopπ cs:0099 EB04 jmp TSTFileS.46 (009F)π *** Jump to the start of the Loopπ cs:009B FF065001 inc Word ptr [TSTFileS.RECCNT]π *** The Loop returns to here to inC the loop counterπTSTFileS.46: FillRec (RecCnt);π cs:009F A15001 mov ax,[TSTFileS.RECCNT]π *** Move our RecCnt Var into AX registerπ cs:00A2 31D2 xor dx,dxπ *** Clear the DX Registerπ cs:00A4 52 push dxπ cs:00A5 50 push axπ *** Push the DX and AX Registers on the stack. Remember ourπ FillRec Routine expects a LongInt to be passed and RecCntπ is only a Word. So it Pushes the DX as the 0 Upper Wordπ of the LongInt.π cs:00A6 0E push csπ *** Push the code segment For some reasion.π cs:00A7 E856FF call TSTFileS.FILLRECπ *** Call our FillRec RoutineπTSTFileS.48: Write (MyTypedFile , Rec);π cs:00AA BF4400 mov di,0044π cs:00AD 1E push dsπ cs:00AE 57 push diπ *** These instructions push the address of MyTypedFile Recordπ on the stack. The first paramiterπ cs:00AF BF4401 mov di,0144π cs:00B2 1E push dsπ cs:00B3 57 push diπ *** These instructions push the address of Rec Recordπ on the stack. The second paramiterπ cs:00B4 9AAA05262D call 2D26:05AAπ *** Call the System Function to Write a Typed File. (In next msg)π cs:00B9 83C404 add sp,0004π *** Remove our passed parameters from the stackπTSTFileS.51: FillRec (RecCnt + $FFFF);π cs:00BC A15001 mov ax,[TSTFileS.RECCNT]π cs:00BF 05FFFF add ax,FFFFπ cs:00C2 31D2 xor dx,dxπ cs:00C4 52 push dxπ cs:00C5 50 push axπ cs:00C6 0E push csπ cs:00C7 E836FF call TSTFileS.FILLRECπ *** Now heres a NASTY littel bug With the code!!! Look at theπ above routine. We wanted to pass a LongInt $FFFF + rec cntπ But we wound up adding the $FFFF to a Word then passing aπ LongInt. if you Compile the sample pas File you'll be ableπ to see this bug in action.. Good reasion to use a Debugger.πTSTFileS.55: BlockWrite (MyUnTypedFile, Rec, Sizeof (MyRec))π cs:00CA BFC400 mov di,00C4π cs:00CD 1E push dsπ cs:00CE 57 push diπ *** These instructions push the address of MyUnTypeFile Recordπ on the stack. The First paramiterπ cs:00CF BF4401 mov di,0144π cs:00D2 1E push dsπ cs:00D3 57 push diπ cs:0594 26817D02B3D7 cmp es:Word ptr [di+02],D7B3π *** Armed With the address of the File Record in ES:DIπ Check the File mode For a In/Out operation. See Dosπ Unit Constant definitions.π cs:059A 7406 je 05A2π *** if that Compare was equal then jump to returnπ cs:059C C7063C006700 mov Word ptr [SYSTEM.inOUTRES],0069π *** if we didn't jump then put File not oopen For output inπ Ioresult.π cs:05A2 C3 retπ *** Go back to where we were calledπ cs:05A3 B43F mov ah,3Fπ cs:05A5 BA6400 mov dx,0064π cs:05A8 EB05 jmp 05AFππ *** The Write instruction entered the system Unit hereπ cs:05AA B440 mov ah,40π *** Load Dos Function in AHπ cs:05AC BA6500 mov dx,0065π *** Default error code 101 disk Write error load in DXπ cs:05AF 55 push bpπ *** Save the BP registerπ cs:05B0 8BEC mov bp,spπ *** Load the BP Register With the stack Pointerπ cs:05B2 C47E0A les di,[bp+0A]π *** Load Address of MyTypeFile Rec in ES:SIπ cs:05B5 E8DCFF call 0594π *** Call check For File mode. See top of messageπ cs:05B8 751B jne 05D5π *** if error jump out of thisπ cs:05BA 1E push dsπ cs:05BB 52 push dxπ *** Save These Registers as we'er going to use themπ cs:05BC C55606 lds dx,[bp+06]π *** Load the address of our Rec in DS:DX Registersπ cs:05BF 268B4D04 mov cx,es:[di+04]π *** Look up Record structure For a File Rec and you'll seeπ that RecSize is Byte # 4. Move that value to CXπ cs:05C3 268B1D mov bx,es:[di]π *** First Byte of a File Rec is the Handel. Move into BXπ cs:05C6 CD21 int 21π *** Make the Dos CALL to Write. AH = 40π BX = File Handelπ CX = # of Bytes to Write.π DS:DX = Address of Bufferπ Returns Error In AX if Carry flag set orπ if good CF = 0 number of Bytes written in AXπ cs:05C8 5A pop dxπ cs:05C9 1F pop dsπ *** Restore the Registersπ cs:05CA 7206 jb 05D2π *** Jump if there was an error (if Carry flag Set)π cs:05CC 3BC1 cmp ax,cxπ *** Comp Bytes requested to what was writtenπ cs:05CE 7405 je 05D5π *** if equal then jump out we'r just about doneπ cs:05D0 8BC2 mov ax,dxπ *** Move default errorcode 101 to AXπ cs:05D2 A33C00 mov [SYSTEM.inOUTRES],ax <--Set Ioresultπ *** Store 101 to Ioresultπ cs:05D5 5D pop bpπ *** Restore BP registerπ cs:05D6 CA0400 retf 0004π *** We'r out of hereππ cs:05D9 B33F mov bl,3Fπ cs:05DB B96400 mov cx,0064π cs:05DE EB05 jmp 05E5πππ *** The BlockWrite instruction entered the system Unit hereπ cs:05E0 B340 mov bl,40π *** Move Dos Function in BLπ cs:05E2 B96500 mov cx,0065π *** Default error 101 Write error in CXπ cs:05E5 55 push bpπ *** Save BP Registerπ cs:05E6 8BEC mov bp,spπ *** Move Stack Pointer to BPπ cs:05E8 C47E10 les di,[bp+10]π *** Load Address of MyUnTypedFile Record in ES:DIπ cs:05EB E8A6FF call 0594π *** Check For Open in Write Mode See top of messageπ cs:05EE 753F jne 062Fπ *** Jump if not in Write modeπ cs:05F0 8B460A mov ax,[bp+0A] ]π *** Move File Record cnt in to axπ cs:05F3 0BC0 or ax,axπ *** Check For 0 Record requestπ cs:05F5 741C je 0613π *** Jump if 0 rec requestedπ cs:05F7 1E push dsπ cs:05F8 51 push cxπ *** Save them we'er going to use themπ cs:05F9 26F76504 mul es:Word ptr [di+04]π *** Multiply Record size With RecCnt in AX result in DX & AXπ cs:05FD 8BC8 mov cx,axπ 17 05-28-9313:51ALL SWAG SUPPORT TEAM ZTRAS.PAS IMPORT 33 Unit Globals;ππInterfaceππUses Crt{, Dos?};ππ{ Special keyboard Characters: }π{ I've squeezed them into a couple of lines so that they'd fit in aπmessage.. might be an idea to expand them back to ~20 lines or so..}ππ NULL = #0; BS = #8; ForMFEED = #12; CR = #13; ESC = #27;ππ HOMEKEY = #199; {Values apply if only used With the 'Getkey' Function}π endKEY = #207; UPKEY = #200; doWNKEY = #208;π PGUPKEY = #201; PGDNKEY = #209; LEFTKEY = #203;π inSKEY = #210; RIGHTKEY = #205; DELKEY = #211;π CTRLLEFTKEY = #243; CTRLRIGHTKEY = #244;π F1 = #187; F2 = #188; F3 = #189; F4 = #190; F5 = #191;π F6 = #192; F7 = #193; F8 = #194; F9 = #195; F10 = #196;ππType CurType = ( off, Big, Small );ππVar Ins : Boolean; { Global Var containing status of Insert key}ππ{-----------------------------------------------------------------------------}πFunction GetKey : Char;πProcedure EdReadln(Var S : String);ππProcedure Cursor( Size : CurType ); { Either off, Big or Small }πProcedure ChangeCursor( Ins : Boolean );ππ{-----------------------------------------------------------------------------}πImplementationππFunction GetKey; { : Char; }ππVar C : Char;ππbeginπ C := ReadKey;π Repeatπ if C = NULL thenπ beginπ C := ReadKey;π if ord(C) > 127 thenπ C := NULLπ elseπ GetKey := Chr(ord(C) + 128);π end else GetKey := C;π Until C <> NULL;πend; { GetKey }ππ{-----------------------------------------------------------------------------}πProcedure EdReadln; { (Var S : String); }ππ{ Legal : IString; MaxLength : Word; Var ESCPressed : Boolean); }ππVar CPos : Word;π Ch : Char;π OldY : Byte;ππ Legal : String[1];π MaxLength : Byte;π EscPressed : Boolean;ππbeginπ OldY := WhereY - 1;π ChangeCursor(Ins);π CPos := 1; {Place cursor at START of line}π{ CPos := Succ(Length(S));} {Whereas this places cursor at end of line}π Legal := ''; {Legal and Maxlength originally passed as params}π MaxLength := Lo( WindMax ) - Lo( WindMin );ππ Repeatπ Cursor( off );π GotoXY(1, WhereY);π Write(S, '':(MaxLength - Length(S)));π GotoXY(CPos, WhereY);π ChangeCursor(Ins);π Ch := GetKey;π Case Ch ofπ HOMEKEY : CPos := 1;π endKEY : CPos := Succ(Length(S));π inSKEY : beginπ Ins := not Ins;π ChangeCursor(Ins);π end;π LEFTKEY : if CPos > 1 then Dec(CPos);π RIGHTKEY : if CPos <= Length(S) then Inc(CPos);π BS : if CPos > 1 thenπ beginπ Delete(S, Pred(CPos), 1);π Dec(CPos);π end;π DELKEY : if CPos <= Length(S) then Delete(S, CPos, 1);π CR : ;π ESC : beginπ S := '';π CPos := 1;π end;π elseπ beginπ if ((Legal = '') or (Pos(Ch, Legal) <> 0)) andπ ((Ch >= ' ') and (Ch <= '~')) andπ (Length(S) < MaxLength) thenπ beginπ if Ins then Insert(Ch, S, CPos) elseπ if CPos > Length(S) then S := S + Ch elseπ S[CPos] := Ch;π Inc(CPos);π end;π end;π end; { Case }π Until (Ch = CR);π Cursor( Small );π ESCPressed := Ch <> ESC;π Writeln;πend; { EditString }ππ{-----------------------------------------------------------------------------}πProcedure Cursor; { ( Size : CurType ); { Either off, Big or Small }ππVar Regs : Registers;ππbeginπ With Regs Do beginπ Ax := $100;π Case Size ofπ off : Cx := $3030;π Big : Cx := $0F;π Small : Cx := $607;π end;π Intr ( $10, Regs );π end;πend;ππ{-----------------------------------------------------------------------------}πProcedure ChangeCursor; { ( Ins : Boolean ); }π{Changes cursor size depending on status of insert key}ππbeginπ if Ins then Cursor( Small ) else Cursor( Big );πend;ππbeginπend.π 18 05-10-9314:24ALL COLIN BUCKLEY Compiler Directives (232)T_Pascal_R 32 So I'm using a common include file, which I'll add to the end of this message,πand I've noticed something very strange. I used the Object browser to findπall the units, and I have triple checked to ensure they all include theπinclude file and this is what I've found:ππWith DEBUGGING set my file compiles to 115KπWithout DEBUGGING set 81KππWhen I look at the file there is still loads of symbol information there.πAfter TDStrip of the above file, it's down to 55K (81-55=26). That's a 26Kπdifference. Where is it coming from? Sure I'm using CRT and DOS, andπobviously the include file doesn't work for them, but after looking at theπremaining symbol information, it's alot of stuff from my various unitsπaswell as CRT and DOS.ππWhat's the deal with the symbols coming from my units when I tell themπnot to? I say symbols as it's all declarations from my interfaceπsections like variables and procedure names, etc.ππAnyways, I wasn't interested in using multiple configuration files, butπI guess I'll have to as I forgot about Borland units, and I guess everyoneπelse did aswell.ππ----------------------------- OPTIONS.INC --------------------------------π{πTurbo Pascal Compiler Directivesπ}ππ{$DEFINE i286}π{$DEFINE DEBUGGING}ππ{$A+} { Data Alignment........Word }π{$I-} { I/O Checking..........Off }π{$X-} { Enhanced Syntax.......Off }π{$V-} { String Type Checking..Relaxed }π{$P-} { Open Strings..........Off }π{$T-} { @ Pointers............UnTyped }ππ{$IFDEF i286}π{$G+} { 286 OpCodes...........On }π{$ELSE}π{$G-} { 286 OpCodes...........Off }π{$ENDIF}ππ{$IFDEF OVERLAYS}π{$F+} { Far Calls.............On }π{$O+} { Overlays Allowed......Yes }π{$ELSE}π{$F-} { Far Calls.............Off }π{$O-} { Overlays Allowed......No }π{$ENDIF}ππ{$IFDEF DEBUGGING}π{$B+} { Boolean Evaluation....Complete }π{$D+} { Debugging Info........On }π{$L+} { Line Numbers..........On }π{$Y+} { Symbol Information....On }π{$R+} { Range Checking........On }π{$S+} { Stack Checking........On }π{$Q+} { Overflow Checking.....On }π{$ELSE}π{$B-} { Boolean Evaluation....Short Circuit }π{$D-} { Debugging Info........Off }π{$L-} { Line Numbers..........Off }π{$Y-} { Symbol Information....Off }π{$R-} { Range Checking........Off }π{$S-} { Stack Checking........Off }π{$Q-} { Overflow Checking.....On }π{$ENDIF}ππ{πProgram Memory Requirementsπ}π{$M 32000,0,0} { Stack Size............32000 Heap.....0 }ππ.----------------------------------------------------.π| Colin Buckley |π| Toronto, Ontario, Canada |π| InterNet: colin.buckley@rose.com |π| |π| So Eager to Play, So Relunctant to Admit it... |π`----------------------------------------------------'ππ---π ■ RoseReader 2.10ß P003288 Entered at [ROSE]π * Rose Media, Toronto, Canada : 416-733-2285π * PostLink(tm) v1.04 ROSE (#1047) : RelayNet(tm)ππ 19 05-31-9308:05ALL FLOOR NAAIJKENS RANDOM NUMBER GENERATOR IMPORT 21 ==============================================================================π BBS: The Sand Box BBS - SourceNet Central HUBπ To: JUD MCCRANIE Date: 12-17─92 (16:42)πFrom: TREVOR CARLSEN Number: 531 [87] FD-PascalπSubj: BP 7 DIFFERENCE Status: Publicπ------------------------------------------------------------------------------π JM> The behavior of RANDOM (with RandSeed set) is different inπ JM> BP7 (and presumably TP7) from that in TP 5.5. (I don't knowπ JM> how TP 6 compares since I burned it off my disk).ππ JM> RandSeed := 123;π JM> for i := 1 to 8 do writeln( random( 1000));ππ JM> TP 5.5: 343 282 986 996 781 855 343 32π JM> BP 7.0: 859 80 869 854 317 257 20 46ππ JM> ...both are consistant, but they are different sequences.π JM> This can have some dire consequences. ...ππIt certainly could if you did not know about it and unfortunately I canπfind no reference to the changes in the documentation. (Richard Nelson?)ππHere is a fix (supplied to me via Netmail courtesy Joe Lamoine - thanks Joe).ππ>Quote........ππI posted a message on Compuserve last nite and got the followingπunit in a response. It seems to work fine!πππ{ * Turbo Pascal Runtime Library Version 6.0 * ;π * Random Number Generator * ;π * * ;π * Copyright (C) 1988,92 Borland International * }ππ unit TP6Rand;ππ interfaceππ function Random(Max: Integer): Integer;ππ implementationππ constπ { Scaling constant}π ConstM31 = Longint(-31);π { Multiplication factor}π Factor: Word = $8405;πππ function NextRand: Longint; assembler;π { Compute next random numberπ New := 8088405H * Old + 1π Out DX:AX = Next random numberπ }π asmπ MOV AX,RandSeed.Word[0]π MOV BX,RandSeed.Word[2]π MOV CX,AXπ MUL Factor.Word[0] { New = Old.w0 * 8405H }π SHL CX,1 { New.w2 += Old.w0 * 808H }π SHL CX,1π SHL CX,1π ADD CH,CLπ ADD DX,CXπ ADD DX,BX { New.w2 += Old.w2 * 8405H }π SHL BX,1π SHL BX,1π ADD DX,BXπ ADD DH,BLπ MOV CL,5π SHL BX,CLπ ADD DH,BLπ ADD AX,1 { New += 1 }π ADC DX,0π MOV RandSeed.Word[0],AXπ MOV RandSeed.Word[2],DXπ end;ππfunction Random(Max: Integer): Integer; assembler;π asmπ CALL NextRandπ XOR AX,AXπ MOV BX,Max.Word[0]π OR BX,BXπ JE @@1π XCHG AX,DXπ DIV BXπ XCHG AX,DXπ @@1:π end;ππend.ππ>End of quote.πππTeeCeeπππ--- TC-ED v2.01π * Origin: The Pilbara's Pascal Centre (+61 91 732930) (3:690/644)π 20 06-22-9309:24ALL SWAG SUPPORT TEAM Hi Resolution Timer IMPORT 20 UNIT Timer;ππ{ TIMER - Fine resolution timer functions }ππINTERFACEπUSES Crt,Dos;πCONSTπ TixSec = 18.20648193;π TixMin = TixSec * 60.0;π TixHour = TixMin * 60.0;π TixDay = TixHour * 24.0;πTYPEπ DiffType = String[16];πVARπ tGet : Longint ABSOLUTE $0040:$006C;πFUNCTION tStart: Longint;πFUNCTION tDiff(StartTime,EndTime: Longint) : Real;πFUNCTION tFormat(T1,T2:Longint): DiffType;πPROCEDURE GetTime(H,M,S,S100:Word);ππIMPLEMENTATIONππVARπ TimeDiff : DiffType;ππ{ tStart - wait for a new tick, and return theπ tick number to the caller. The wait allowsπ us to be sure the user gets a start at theπ beginning of the second. }ππFUNCTION tStart: Longint;πVARπ StartTime : Longint;πBEGINπ StartTime := tGet;π WHILE StartTime = tGet DO;π tStart := tGetπEND;ππ{ tDiff - compute the difference between twoπ timepoints (in seconds). }ππFUNCTION tDiff(StartTime,EndTime: Longint) : Real;πBEGINπ tDiff := (EndTime-StartTime)/TixSec;πEND;ππPROCEDURE GetTime(H,M,S,S100:Word);πVARπ Regs : Registers;πBEGINπ Regs.AH := $2C;π MsDos(Regs);π H := Regs.CH;π M := Regs.CL;π S := Regs.DH;π S100 := Regs.DLπEND;ππ{ tFormat - given two times, return a pointerπ to a (static) string that is the differenceπ in the times, formatted HH:MM:SS }ππFUNCTION tFormat(T1,T2:Longint): DiffType;ππFUNCTION rMod(P1,P2: Real): Real;πBEGINπ rMod := Frac(P1/P2) * P2πEND;ππVARπ Temp : Real;π tStr : String;π TempStr : String[2];π TimeValue : ARRAY [1..4] OF Longint;π I : Integer;πBEGINπ Temp := t2-t1; { Time diff. }π {Adj midnight crossover}π IF Temp < 0 THENπ Temp := Temp + TixDay;π TimeValue[1] := Trunc(Temp/TixHour); {hours}π Temp := rMod(Temp,TixHour);π TimeValue[2] := Trunc(Temp/TixMin); {minutes}π Temp := rMod(Temp,TixMin);π TimeValue[3] := Trunc(Temp/TixSec); {seconds}π Temp := rMod(Temp,TixSec); {milliseconds}π TimeValue[4] := Trunc(Temp*100.0/TixSec+0.5);π STR(TimeValue[1]:2,tStr);π IF tStr[1] = ' ' THEN tStr[1] := '0';π FOR I := 2 TO 3 DOπ BEGINπ STR(TimeValue[I]:2,TempStr);π IF TempStr[1]=' ' THENπ TempStr[1]:='0';π tStr := tStr + ':'+ TempStrπ END;π STR(TimeValue[4]:2,TempStr);π IF TempStr[1]=' ' THEN TempStr[1]:='0';π tStr := tStr + '.' + TempStr;π tFormat := tStrπEND;ππEND.π 21 07-16-9306:11ALL SWAG SUPPORT TEAM A source code mangler IMPORT 43 èo {πHere is a VERY simple source-code mangler that I just made. It simply:ππ1) Removes whitespace,π2) Removes comments (but not Compiler-directives!),π3) Makes everything upper-Case.π4) Make lines max. 127 Chars wide (max. For Turbo Pascal),π5) Doesn't mess up literal Strings :-)ππI don't imagine that this is anything Near perfect - but it's better thanπnothing...ππ}ππProgram Mangler;ππConstπ Alpha : Set of Char = ['a'..'z', 'A'..'Z', '0'..'9'];ππVarπ F, F2 : Text;π R, S : String;π X : Byte;π InString : Boolean;ππFunction NumChar(C : Char; S : String; Max : Byte) : Byte;πVarπ N, Y : Byte;πbeginπ N := 0;π For Y := 1 to Max doπ if S[Y] = C then Inc(N);π NumChar := N;πend;ππFunction TrimF(T : String) : String;πVarπ T2 : String;πbeginπ T2 := T;π While (Length(T2) > 0) and (T2[1] = ' ') doπ Delete(T2, 1, 1);π TrimF := T2;πend;ππFunction Trim(T : String) : String;πVarπ T2 : String;πbeginπ T2 := TrimF(T);π While (Length(T2) > 0) and (T2[Length(T2)] = ' ') doπ Delete(T2, Length(T2), 1);π Trim := T2;πend;ππProcedure StripComments(Var T : String);πVarπ Y : Byte;π Rem : Boolean;πbeginπ Rem := True;π if Pos('(*', T) > 0 thenπ beginπ For Y := Pos('(*', T) to Pos('*)', T) doπ if (T[Y] = '$') or (T[Y] = '''') thenπ Rem := False;π if (Rem) and (not Odd(NumChar('''', T, Pos('(*', T)))) thenπ Delete(T, Pos('(*', T), Pos('*)', T)+2-Pos('(*', T));π end;π if Pos('{', T) > 0 thenπ beginπ For Y := Pos('{', T) to Pos('}', T) doπ if (T[Y] = '$') or (T[Y] = '''') thenπ Rem := False;π if (Rem) and (not Odd(NumChar('''', T, Pos('(*', T)))) thenπ Delete(T, Pos('{', T), Pos('}', T)+1-Pos('{', T));π end;πend;ππbeginπ ReadLn(S);π Assign(F, S);π Reset(F);π ReadLn(S);π Assign(F2, S);π ReWrite(F2);π R := '';π S := '';ππ While not EoF(F) doπ beginπ ReadLn(F, R);π StripComments(R);π R := Trim(R);π X := 1;π While X <= Length(R) doπ beginπ InString := (R[X] = '''') xor InString;π if not InString thenπ beginπ if R[X] = #9 thenπ R[X] := ' ';π if ((R[X] = ' ') and (R[X+1] = ' ')) thenπ beginπ Delete(R, X, 1);π if X > 1 thenπ Dec(X);π end;π if ((R[X] = ' ') and not(R[X+1] in Alpha)) thenπ Delete(R, X, 1);π if ((R[X+1] = ' ') and not(R[X] in Alpha)) thenπ Delete(R, X+1, 1);π R[X] := UpCase(R[X]);π end;π Inc(X);π end;π if (Length(R) > 0) and (R[Length(R)] <> ';') thenπ R := R+' ';π if Length(R)+Length(S) <= 127 thenπ S := TrimF(S+R)π elseπ beginπ WriteLn(F2, Trim(S));π S := TrimF(R);π end;π end;ππ WriteLn(F2, S);π Close(F);π Close(F2);πend.π{π > 1) Remove whitespace.πJust removes indentation now.π > 2) Put lines together (max. length approx. 120 Chars).πThis is going to be one of the harder parts.π > 3) Make everything lower-Case (or upper-Case).πNo need.. see 4.π4. Convert all Types, Consts, and VarS to an encypted name, like so:π IIl0lll1O0lI1π5. Convert all Procedures, and Functions like #4π6. On Objects, Convert all "data" fields. Leave alone all others except Forπthe "ConstRUCtoR" and on that, only check to see if any Types are being used.πConstructors are the only ones that can change from the ancestor.π7. on Records, When Typed like this:πaRec.Name:='Rob Green'; check to see if arec is in the list, if not, skip.πif like this:π With arec doπ name:='Rob Green'; do the same as above, but check For begin and end.π8. Leave externals alone.π9. Also mangle the Includes.π10. Leave Any Interface part alone, and only work With the Implementation.πThis is what my mangler currently does.(all except For #7 and #10, havent gotπthat Far yet.) Any ways it works pretty good. im happy With the results iπam getting With it. It makes it "VERY" hard to read. The only thing i seeπhaving trouble With down the line, is the "Compressing" of mulitiple lines.ππAnyways, heres a small Program, and then what PAM(Pascal automatic mangler)πdid to it:π}ππProgram test;ππTypeπ pstr30 = ^str30;π str30 = String[30];ππVarπ b : Byte;π s : pstr30;ππFunction hex(b : Byte) : String;πConstπ Digits : Array [0..15] of Char = '0123456789ABCDEF';πVarπ s:String;πbeginπ s:='';π s[0] := #2;π s[1] := Digits [b shr 4];π s[2] := Digits [b and $F];π hex:=s;πend;ππbeginπ new(s);π s^:='Hello world';π Writeln(s^);π Writeln('Enter a Byte to convert to hex:');π readln(b);π s^:=hex(b);π Writeln('Byte :',b,' = $',s^);π dispose(s);πend.πππProgram test;πTypeπ IO1II0IO00O = ^II0lOl1011I;π II0lOl1011I = String[30];πVarπ III0O1ll10l:Byte;π I11110I11Il0:IO1II0IO00O;ππFunction Il00O011IO0I(III0O1ll10l:Byte):String;πConstπ Illl1OOOO0I : Array [0..15] of Char = '0123456789ABCDEF';πVarπ I11110I11Il0:String;πbeginπ I11110I11Il0:='';π I11110I11Il0[0] := #2;π I11110I11Il0[1] := Illl1OOOO0I [III0O1ll10l shr 4];π I11110I11Il0[2] := Illl1OOOO0I [III0O1ll10l and $F];π Il00O011IO0I:=I11110I11Il0;πend;πbeginπ new(I11110I11Il0);π I11110I11Il0^:='Hello world';π Writeln(I11110I11Il0^);π Writeln('Enter a Byte to convert to hex:');π readln(III0O1ll10l);π I11110I11Il0^:=Il00O011IO0I(III0O1ll10l);π Writeln('Byte :',III0O1ll10l,' = $',I11110I11Il0^);π dispose(I11110I11Il0);πend.ππ 22 07-16-9306:13ALL KENT BRIGGS Randmom Number Function IMPORT 16 èo ===========================================================================π BBS: Canada Remote SystemsπDate: 06-18-93 (23:27) Number: 26893πFrom: KENT BRIGGS Refer#: NONEπ To: BRIAN PAPE Recvd: NO πSubj: RANDOM NUMBERS Conf: (1221) F-PASCALπ---------------------------------------------------------------------------π -=> Quoting Brian Pape to Erik Johnson <=-ππ BP> Please- I *am* looking for the source code to a decent random numberπ BP> generator so that I'm not dependant on Borland.ππ Brian, Borland did change their random:word function when they releasedπ 7.0. However the random:real function, the randomize procedure, and theirπ method of updating randseed remain the same as ver 6.0. Using DJ Murdoch'sπ CycleRandseed procedure and reverse engineering TP6's and TP7's Randomπ functions, I came up with the following routines:ππconst rseed: longint = 0;ππprocedure randomize67; {TP 6.0 & 7.0 seed generator}πbeginπ reg.ah:=$2c;π msdos(reg); {get time: ch=hour,cl=min,dh=sec,dl=sec/100}π rseed:=reg.dx;π rseed:=(rseed shl 16) or reg.cx;πend;ππfunction rand_word6(x: word): word; {TP 6.0 RNG: word}πbeginπ rseed:=rseed*134775813+1;π rand_word6:=(rseed shr 16) mod x;πend;ππfunction rand_word7(x: word): word; {TP 7.0 RNG: word}πbeginπ rseed:=rseed*134775813+1;π rand_word7:=((rseed shr 16)*x+((rseed and $ffff)*x shr 16)) shr 16;πend;ππfunction rand_real67: real; {TP 6.0 & 7.0 RNG: real}πbeginπ rseed:=rseed*134775813+1;π if rseed<0 then rand_real67:=rseed/4294967296.0+1.0 elseπ rand_real67:=rseed/4294967296.0;πend;ππIf anyone can improve on these please post some code here, thanks.ππ___ Blue Wave/QWK v2.12π--- Renegade v06-11 Betaππ * Origin: Snipe's Castle BBS, Waco TX (817)-757-0169 (1:388/26)π 23 08-18-9312:20ALL JOSE ALMEIDA Get the active code page IMPORT 20 èo { Gets the active (set by user) and system (at boot byte) code page.π Part of the Heartware Toolkit v2.00 (HTelse.PAS) for Turbo Pascal.π Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.π I can also be reached at RIME network, site ->TIB or #5314.π Feel completely free to use this source code in any way you want, and, ifπ you do, please don't forget to mention my name, and, give me and Swag theπ proper credits. }ππPROCEDURE Get_Code_Page(var Active_CP : word;π var System_CP : word;π var Error_Code : byte);π{ DESCRIPTION:π Gets the active (set by user) and system (at boot byte) code page.π SAMPLE CALL:π Get_Code_Page(Active_CP,Default_CP,Error_Code);π RETURNS:π Active : active code page set by userπ System : system code page at boot timeπ Error_Codeπ 0 : no errorπ else : see The Programmers PC Source Book 3.191π NOTES:π Applies to all versions beginning with v3.3.π See Get_Code_Page_Text() in order to get string text. }ππvarπ HTregs : registers;ππBEGIN { Get_Code_Page }π HTregs.AX := $6601;π MsDos(HTregs);π if HTregs.Flags and FCarry <> 0 thenπ beginπ Active_CP := $FFFF; { on error set to $FFFF }π System_CP := $FFFF; { on error set to $FFFF }π Error_Code := HTregs.AL;π endπ elseπ beginπ Active_CP := HTregs.BX;π System_CP := HTregs.DX;π Error_Code := 0;π end;πEND; { Get_Code_Page }ππππFUNCTION Get_Code_Page_Text(CP : word) : String14;ππ{ DESCRIPTION:π Gets the current active code page in string form.π SAMPLE CALL:π St := Get_Code_Page_Text(860);π RETURNS:π e.g.: 'Portugal'π NOTES:π None. }ππBEGIN { Get_Code_Page_Text }π case CP ofπ 437 : Get_Code_Page_Text := 'USA English';π 850 : Get_Code_Page_Text := 'Multilingual';π 852 : Get_Code_Page_Text := 'CZ/SL/HU/PL/YU';π { CZ and SL = Czechoslovakia (Czech & Slovak) }π { HU = Hungary }π { PL = Poland }π { YU = Yugoslavia }π 854 : Get_Code_Page_Text := 'Spain';π 860 : Get_Code_Page_Text := 'Portugal';π 863 : Get_Code_Page_Text := 'Canada-French';π 865 : Get_Code_Page_Text := 'Norway/Denmark';π elseπ Get_Code_Page_Text := 'Unknown';π end;πEND; { Get_Code_Page_Text }π 24 08-18-9312:27ALL JOSE ALMEIDA Intra-App Comm Area IMPORT 15 èo { Gets or puts information in the Intra-Application Communications Area (ICA).π Part of the Heartware Toolkit v2.00 (HTmemory.PAS) for Turbo Pascal.π Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.π I can also be reached at RIME network, site ->TIB or #5314.π Feel completely free to use this source code in any way you want, and, ifπ you do, please don't forget to mention my name, and, give me and Swag theπ proper credits. }ππPROCEDURE ICA(GetPut : boolean;π var SourceDest);π{ DESCRIPTION:π Gets or puts information in the Intra-Application Communications Area (ICA).π SAMPLE CALL:π ICA(True,MyVar);π orπ ICA(False,MyVar);π RETURNS:π See notes (bellow).π NOTES:π These sixteen bytes, called the Intra-Application Communications Areaπ (ICA) can be used by any program for any purpose, Usually it is usedπ to pass data betwenn two or more programs. Not many programs use thisπ area. If you wish to use this area, make sure checksums and signaturesπ are used to insure the reliability of your data, since another programπ may also decide to use this area.π [in The Assembly Language Database, Peter Norton]π The incomming SourceDir variable may be of any type.π Nevertheless, the size of that variable MUST be at least 16 bytes long,π or unpredictable results may occur...π The programer before changing this area contents, should keep itsπ contents in a variable for later restore. It is not a very good ideiaπ to not restore the contents before the program end, because thatπ area may being used by another program. }ππBEGIN { ICA }π if GetPut thenπ Move(Mem[$0000:$04F0],SourceDest,16)π elseπ Move(SourceDest,Mem[$0000:$04F0],16)πEND; { ICA }π 25 08-18-9312:28ALL JOSE ALMEIDA Get Print Screen Status IMPORT 8 èo { Gets the status of the last or current Print Screen operation.π Part of the Heartware Toolkit v2.00 (HTparal.PAS) for Turbo Pascal.π Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.π I can also be reached at RIME network, site ->TIB or #5314.π Feel completely free to use this source code in any way you want, and, ifπ you do, please don't forget to mention my name, and, give me and Swag theπ proper credits. }ππFUNCTION PrtSc_Status : byte;π{ DESCRIPTION:π Gets the status of the last or current Print Screen operation.π SAMPLE CALL:π NB := PrtSc_Status;π RETURNS:π 00h : Print Screen completeπ 01h : Print Screen currently in progressπ FFh : Error occurred during Print Screen }ππBEGIN { PrtSc_Status }π PrtSc_Status := Mem[$0000:$0500];πEND; { PrtSc_Status }π 26 08-27-9320:00ALL SWAG SUPPORT TEAM Finding Anagrams IMPORT 47 èo {$A+,B+,D+,E-,F+,G+,I+,L+,N-,O+,P+,Q+,R+,S+,T+,V-,X+,Y+}π{$M 65520,100000,655360}π{πProgram compiled and tested With BP 7.0ππWARNING since this Program is not using the fastest algorithm toπfind it's Anagrams, long Delays can be expected For largeπinput-Strings.ππTest have shown the following results:ππ Length of Input Number of anagrams foundππ 2 2π 3 6π 4 24π 5 120π 6 720π 7 5040ππAs can plainly be seen from this, the number of Anagrams For aπString of length N is a direct Function of the number of AnagramsπFor a String of N-1. In fact the result is f(N) = N * f(N-1).ππYou might have recognised the infamous FACTORIAL Function!!!ππTypeπ MyType = LongInt;ππFunction NumberOfAnagrams(Var InputLen : MyType) : MyType;ππ Varπ Temp : MyType;ππ beginπ Temp := InputLen;π if Temp >1 thenπ beginπ Temp := Temp - 1;π NumberOfAnagrams := InputLen * NumberOfAnagrams(Temp);π end elseπ NumberOfAnagrams := InputLen;π end;ππThe above Function has been tested and found to work up to an inputπlength of 12. After that, Real numbers must be used. As a side noteπthe Maximum value computable was 1754 With MyType defined asπExtended and Numeric-Coprocessor enabled of course. Oh and BTW, theπparameter is passed as a Var so that the Stack doesn't blow up whenπyou use Extended Type!!!! As a result, you can't pass N-1 to theπFunction. You have to STORE N-1 in a Var and pass that as parameter.πThe net effect is that With Numeric Copro enabled, at 1754 it blowsπup because of a MATH OVERFLOW, not a STACK OVERFLOW!!!ππBased on these findings, I assume the possible anagrams can beπcomputed a lot faster simply by Realising that the possible AnagramsπFor an input length of (N) can be found by finding all anagrams forπan input Length of (N-1) and inserting the additional letter in eachπ(N) positions in those Strings. Since this can not be doneπrecursively in memory, the obvious solution would be to to outputπthe anagrams strating With the first 4 or 5 caracters to a File,πbecause those can be found quickly enough, and then to read in eachπString and apply the following caracters to each and Repeat thisπprocess Until the final File is produced.ππHere is an example:ππ Anagrams For ABCDππ Output Anagrams For AB to Fileππ Giving AB and BAππ read that in and apply the next letter in all possible positionsππ Givingπ abCπ aCbπ Cabπ &π baCπ bCaπ Cbaππ Now Apply the D to this and getππ abcDπ abDcπ aDbcπ Dabcπ &ππ acbDπ acDbπ aDcbπ Dacbππ Etc... YOU GET THE POINT!!!ππBTW Expect LARGE Files if you become too enthousiastic With this!!!ππ An Input of just 20 caracters long will generate a File ofππ 2,432,902,008,176,640,000 Anagramsπ That'sπ 2.4 Quintillion Anagramsππ Remember that each of those are 20 caracters long,π add Carriage-return and line-feeds and you've got yourself aπ HUGE File ;-)ππ In fact just a 10 Caracter input length will generate 3.6 Millionπ Anagrams from a 10 Caracter input-String. Again add Cr-LFs andπ you've got yourself a 43.5 MEGAByte File!!!!!! but consider youπ are generating it from the previous File which comes to 3.5 MEGπ For an Input Length of 9 and you've got yourself 45 MEG of DISK inπ use For this job.ππ}πUsesπ Strings, Crt;ππConstπ MaxAnagram = 1000;ππTypeπ AnagramArray = Array[0..MaxAnagram] of Word;π AnagramStr = Array[0..MaxAnagram] of Char;ππVarπ Target : AnagramStr;π Size : Word;π Specimen : AnagramArray;π Index : Word;π AnagramCount : LongInt;ππProcedure working;πConstπ CurrentCursor : Byte = 0;π CursorArray : Array[0..3] of Char = '|/-\';πbeginπ CurrentCursor := Succ(CurrentCursor) mod 4;π Write(CursorArray[CurrentCursor], #13);πend;ππProcedure OutPutAnagram(Target : AnagramStr;π Var Specimen : AnagramArray; Size : Word);πVarπ Index : Word;πbeginπ For Index := 0 to (Size - 1) doπ Write(Target[Specimen[Index]]);π Writeln;πend;ππFunction IsAnagram(Var Specimen : AnagramArray; Size : Word) : Boolean;πVarπ Index1,π Index2 : Word;π Valid : Boolean;πbeginπ Valid := True;π Index1 := 0;π While (Index1<Pred(Size)) and Valid doπ beginπ Index2 := Index1 + 1;π While (Index2 < Size) and Valid doπ beginπ if Specimen[Index1] = Specimen[Index2] thenπ Valid := False;π inc(Index2);π end;π inc(Index1);π end;π IsAnagram := Valid;πend;ππProcedure FindAnagrams(Target : AnagramStr;π Var Specimen : AnagramArray; Size : Word);πVarπ Index : Word;π Carry : Boolean;πbeginπ Repeatπ working;π if IsAnagram(Specimen, Size) thenπ beginπ OutputAnagram(Target, Specimen, Size);π inc(AnagramCount);π end;π Index := 0;π Repeatπ Specimen[Index] := (Specimen[Index] + 1) mod Size;π Carry := not Boolean(Specimen[Index]);π Inc(Index);π Until (not Carry) or (Index >= Size);π Until Carry and (Index >= Size);πend;ππbeginπ ClrScr;π Write('Enter anagram Target: ');π readln(Target);π Writeln;π AnagramCount := 0;π Size := Strlen(Target);π For Index := 0 to MaxAnagram doπ Specimen[Index] := 0;π For Index := 0 to Size - 1 doπ Specimen[Index] := Size - Index - 1;π FindAnagrams(Target, Specimen, Size);π Writeln;π Writeln(AnagramCount, ' Anagrams found With Source ', Target);πend.π 27 08-27-9320:01ALL MARK OUELLET Fast Anagrams IMPORT 20 èo {$A+,B+,D+,E-,F+,G+,I+,L+,N-,O+,P+,Q+,R+,S+,T+,V-,X+,Y+}π{$M 65520,100000,655360}π{π Copyright 1993 Mark Ouellet. All rights reserved.ππ May be freely distributed and incorporated in your own code, in partπ or in it's entirety as long as due credit is given to it's authorππ All I ask is that you state my name if you use ALL or PART of it inπ your own code.π}ππProgram FastAnagrams;ππUsesπ Crt;ππTypeπ StrPointer = ^String;π NodePtr = ^Node;π Node = Recordπ Anagram : StrPointer;π Next : NodePtr;π end;ππVarπ OldAnagrams : NodePtr;π NewAnagrams : NodePtr;π OldCursor : NodePtr;π NewCursor : NodePtr;π InputStr : String;ππProcedure GetInput;πbeginπ ClrScr;π Write('Input your String: ');π readln(InputStr);πend;ππProcedure FindAnagrams;ππVarπ OldIndex : Word;π NewIndex : Word;ππbeginπ OldAnagrams := NIL;π OldCursor := NIL;π NewAnagrams := NIL;π NewCursor := NIL;ππ New(OldCursor);π OldCursor^.Next := OldAnagrams;π GetMem(OldCursor^.Anagram, 2);π OldCursor^.Anagram^ := Copy(InputStr, 1, 1);π OldAnagrams := OldCursor;ππ For OldIndex := 2 to Ord(InputStr[0]) doπ beginπ OldCursor := OldAnagrams;π While OldCursor <> NIL doπ beginπ For NewIndex := 1 to Ord(OldCursor^.Anagram^[0])+1 doπ beginπ New(NewCursor);π NewCursor^.Next := NewAnagrams;π getmem(NewCursor^.Anagram, sizeof(OldCursor^.Anagram^)+1);π NewCursor^.Anagram^ := OldCursor^.Anagram^;π Insert(Copy(InputStr, OldIndex, 1),π NewCursor^.Anagram^, NewIndex);π NewAnagrams := NewCursor;π end;π OldCursor := OldCursor^.Next;π FreeMem(OldAnagrams^.Anagram, Ord(OldAnagrams^.Anagram^[0])+1);π OldAnagrams^.Anagram := nil;π Dispose(OldAnagrams);π OldAnagrams := OldCursor;π end;π OldAnagrams := NewAnagrams;π OldCursor := OldAnagrams;π NewAnagrams := NIL;π NewCursor := NIL;π end;πend;ππProcedure OutputAnagrams;πVarπ Count : Word;πbeginπ Count := 0;π OldCursor := OldAnagrams;π While OldCursor <> NIL doπ beginπ OldCursor := OldCursor^.Next;π Writeln(OldAnagrams^.Anagram^);π FreeMem(OldAnagrams^.Anagram, sizeof(OldAnagrams^.Anagram^));π dispose(OldAnagrams);π OldAnagrams := OldCursor;π Inc(Count);π end;π Writeln;π Writeln(Count, ' Anagrams found.');πend;ππbeginπ GetInput;π Writeln;π Writeln(MaxAvail, ' Available memory.');π Writeln;π FindAnagrams;π OutputAnagrams;πend.π 28 08-27-9320:35ALL DAVID JURGENS dBase II File Structure IMPORT 17 èo HelpPC 2.0 PC Programmers Referenceπ Copyright (c) 1990 David Jurgensππ dBASE - File Header Structure (dBASE II)ππ Offset Size Descriptionππ 00 byte dBASE version number 02h=dBASE IIπ 01 word number of data records in fileπ 03 byte month of last updateπ 04 byte day of last updateπ 05 byte year of last updateπ 06 word size of each data recordπ 08 512bytes field descriptors (see below)π 520 byte 0Dh if all 32 field descriptors used; otherwise 00hππ - dBASE II file header has a fixed size of 521 bytesπππ DBASE - File header structure (DBASE III)ππ Offset Size Descriptionππ 00 byte dBASE vers num 03h=dBASE III w/o .DBTπ 83h=dBASE III w .DBTπ 01 byte year of last updateπ 02 byte month of last updateπ 03 byte day of last updateπ 04 dword long int number of data records in fileπ 08 word header structure lengthπ 10 word data record lengthπ 12 20bytes version 1.0 reserved data spaceπ 32-n 32bytes ea. field descriptors (see below)π n+1 byte 0dH field terminator.πππ - unlike dBASE II, dBASE III has a variable length headerπππ dBASE - Field Descriptorsππ dBASE II Field Descriptors (header contains 32 FDs)ππ Offset Size Descriptionππ 00 11bytes null terminated field name string, 0Dh as firstπ byte indicates end of FDsπ 11 byte data type, Char/Num/Logical (C,N,L)π 12 byte field lengthπ 13 word field data address, (set in memory)π 15 byte number of decimal placesπππ dBASE III Field Descriptors (FD count varies):ππ Offset Size Descriptionππ 00 11bytes null terminated field name stringπ 11 byte data type, Char/Num/Logical/Date/Memoπ 12 dword long int field data address, (set in memory)π 16 byte field lengthπ 17 byte number of decimal placesπ 18 14bytes version 1.00 reserved data areaππ 29 08-27-9320:38ALL GORDON TACKETT Device Driver in TP IMPORT 8 èo {πGORDON TACKETTππIn version 7 of TP/BP you can write a device driver But it is tricky! Theπfollowing code is not fully tested but seems to work. After looking at someπdisassembly listings I added the patch file section. Use or abuse at your ownπrisk :-)π}ππProgram TestDriver;ππProcedure Dev_Strategy; Forward;πProcedure Dev_Int; Forward;ππProcedure DeviceDriverHeader;πbeginπ Inline(π $FFFF/π $FFFF/π $2000/π $0000/π $0000/π $FFFF/$FFFF/$FFFF/$FFFF/0);πEnd;ππProcedure Dev_Strategy;πBeginπEnd;ππProcedure Dev_Int;πBeginπEnd;ππVarπ F : File;ππBeginπ If ParamCount = 999 Thenπ DeviceDriverHeaderπ elseπ Beginπ {patch driver}π movemem(devicedriverheader, DeviceDriverHeader + 3, 20);π Assign(F, ParamStr(0));π Reset(F, 1);π BlockWrite(F, DeviceDriverHeader, 20);π Close(F);π End;πEnd.ππ 30 08-27-9320:38ALL D.J. MURDOCK Another Device in TP IMPORT 42 èo {πI've written a simple device driver in TP, and it works. From some things I'veπheard, it won't work in all versions of DOS (it's an .EXE format device driver,πnot a .BIN format one). There are tons of restrictions on what you can do inπit - DOS isn't reentrant, and the TP system library isn't designed to do thingsπwhile DOS is active, so I don't even let it get initialized, etc., etc.ππIt's still a bit of a mess, but here it is, for your enjoyment and edification:π a character device driver that keeps a buffer of 255 characters, calledπTPDEVICE.ππTo try it out, compile it (you'll need OPro or TPro; sorry, but stack swappingπis essential, and I wouldn't want to try to write code to do it myself), put itπinto your CONFIG.SYS (on a floppy disk, please!) asππ device=tpdev.exeππand then reboot. Hopefully you won't crash, but if you do, you'll have toπreboot from a different disk and remove it from CONFIG.SYS.ππThen you can tryππ COPY TPDEVICE CONππto see the initialization message, andππ ECHO This is a line for the buffer >TPDEVICEππto replace it with a new one.π}π{ DOS character device driver written entirely in TP 6 }ππ{ Written by D.J. Murdoch for the public domain, May 1991 }ππ{$S-,F-} { Stack checking wouldn't work here, and we assume near calls }π{$M $1000,0,0} { We can't use the heap and don't use the stack. Thisπ setting doesn't really matter though, since you normallyπ won't run TPDEV }ππprogram tpdev;ππusesπ opint; { OPro interrupt services, needed for stack switching }ππprocedure strategy_routine(bp:word); interrupt; forward;πprocedure interrupt_routine(bp:word); interrupt; forward;ππprocedure header; assembler;π{ Here's the trick: an assembler routine in the main program, guaranteed toπ be linked first in the .EXE file!!}πasmπ dd $FFFFFFFF { next driver }π dw $8000 { attributes of simple character device }π dw offset strategy_routineπ dw offset interrupt_routineπ db 'TPDEVICE'πend;ππconstπ stDone = $100;π stBusy = $200;ππ cmInit = 0;π cmInput = 4;π cmInput_no_wait = 5;π cmInput_status = 6;π cmInput_flush = 7;π cmOutput = 8;π cmOutput_Verify = 9;π cmOutput_status = 10;π cmOutput_flush = 11;ππtypeπ request_header = recordπ request_length : byte;π subunit : byte;π command_code : byte;π status : word;π reserved : array[1..8] of byte;π case byte ofπ cmInit : (num_units : byte;π first_free : pointer;π args : ^char;π drive_num : byte;);π cmInput : { also used for output }π (media_descriptor : byte;π buffer : pointer;π byte_count : word);π cmInput_no_wait : (next_char : char);π end;ππvarπ local_stack : array[1..4000] of byte;π end_of_stack : byte;π request : ^request_header;π line : string;ππprocedure handler(var regs : intregisters);π{ This routine is called by the strategy routine, and handles all requests.π The data segment is okay, and we're running on the local_stack so we've gotπ plenty of space, but remember:π ****** The initialization code for SYSTEM and all other units hasn'tπ ever been called!! ******** }πbeginπ with request^ doπ beginπ case command_code ofππ cmInit :π beginπ { Last thing in the data segment in TP6 - No heap!!}π first_free := ptr(dseg, ofs(saveint75) + 4);π status := stDone;π line := 'TPDRIVER successfully initialized.';π end;ππ cmInput :π beginπ if byte_count > length(line) thenπ byte_count := length(line);π move(line[1], buffer^, byte_count);π line := copy(line, byte_count + 1, 255);π status := stDone;π end;ππ cmInput_no_wait :π beginπ if length(line) > 0 thenπ beginπ next_char := line[1];π status := stDone;π endπ elseπ status := stBusy;π end;ππ cmInput_Status,π cmOutput_Status,π cmInput_Flush,π cmOutput_Flush : status := stDone;ππ cmOutput,π cmOutput_Verify :π beginπ if byte_count + length(line) > 255 thenπ byte_count := 255 - length(line);π move(buffer^, line[length(line) + 1], byte_count);π line[0] := char(byte(byte_count + length(line)));π status := stDone;π end;π end;π end;πend;ππprocedure RetFar; assembler;π{ Replacement for the IRET code that ends the interrupt routines below }πasmπ mov sp,bpπ pop bpπ pop esπ pop dsπ pop diπ pop siπ pop dxπ pop cxπ pop bxπ pop axπ retfπend;ππprocedure strategy_routine(bp : word);πvarπ regs : intregisters absolute bp;πbeginπ with regs doπ request := ptr(es, bx);π RetFar;πend;ππprocedure interrupt_routine(bp : word);πvarπ regs : intregisters absolute bp;πbeginπ SwapStackandCallNear(Ofs(handler), @end_of_stack, regs);π RetFar;πend;ππbeginπ writeln('TPDEVICE - DOS device driver written *entirely* in Turbo Pascal.');π writeln('Install using DEVICE=TPDEV.EXE in CONFIG.SYS.');π request := @header; { Need a reference to pull in the header. }πend.π 31 08-27-9320:55ALL JACK MOFFITT File at end of EXE IMPORT 25 èo {πJACK MOFFITTππ>Okay, how about this: If I wanted to attach it to the back of an EXE, Iπ>COPY /B it. Now, in the source code, how do I find the picture and setπ>everything up? I mean do you LoadGif (Ofs,Seg) or something? That's whatπ>I mean, and I'm sorry to put you through this.ππOk.. here we go.. everyone seems to be asking this, so i'll just postπsome source. Granted this is not a COMPLETE program, just an example onπhow to read the header, and get a pointer to the GIF.π}ππ(* This code originally by Scott Johnson, I revised it later *)ππfunction GetSize(N : byte) : word;πfunction GetData(N : byte) : pointer;πfunction GetDataCount : byte;ππimplementationππusesπ Dos;ππtypeπ DataRec = recordπ Size : word;π Loc : longint;π end;π DataArray = array [1..255] of DataRec;π DataArrayPtr = ^DataArray;ππ ExeDataRec = recordπ ActSize : word;π end;πππvarπ ExeFile : file;π DataCount : byte; { count of data records }π Data : DataArrayPtr;ππprocedure OpenExe;πbeginπ assign(ExeFile, ParamStr(0));π reset(ExeFile, 1);πend;ππprocedure CloseExe;πbeginπ Close(ExeFile);πend;ππprocedure InitExe;πvarπ ExeHdr : recordπ M, Z : char;π Len : word;π Pages : word;π end;π ExeLoc : longint;π I : byte;π ExeData : ExeDataRec;πbeginπ OpenExe;π BlockRead(ExeFile, ExeHdr, SizeOf(ExeHdr));π if ExeHdr.Len = 0 thenπ ExeHdr.Len := $200;π ExeLoc := (longint(ExeHdr.Pages) - 1) shl 9 + longint(ExeHdr.Len);π Seek(ExeFile, ExeLoc);π BlockRead(ExeFile, DataCount, 1); { read data count byte }π Inc(ExeLoc);π GetMem(Data, SizeOf(DataRec) * DataCount);π for I := 1 to DataCount doπ beginπ Seek(ExeFile, ExeLoc);π BlockRead(ExeFile, ExeData, SizeOf(ExeData));π Data^[I].Loc := ExeLoc;π Data^[I].Size := ExeData.ActSize;π Inc(ExeLoc, ExeData.ActSize + 2);π end;π CloseExe;πend;ππfunction GetSize(N : byte) : word;πbeginπ if N > DataCount thenπ RunError(201);π GetSize := Data^[N].Size;πend;ππfunction GetData(N : byte) : pointer;πvarπ P, D : pointer;π DataLoc : longint;π E : ExeDataRec;πbeginπ if N > DataCount thenπ RunError(201);π GetMem(P, Data^[N].Size);π OpenExe;π Seek(ExeFile, Data^[N].Loc + 2); { +2 is to get past info record }π BlockRead(ExeFile, P^, Data^[N].Size);π CloseExe;π GetData := P;πend;ππfunction GetDataCount : byte;πbeginπ GetDataCount := DataCount;πend;ππbeginπ InitExe;πend.ππ{πOk.. that's it. Call GetData(x) to get the location of the firstπelement. Datacount is the number of GIFs or whatever you have in thereπand the first two bytes are the actual size.. So to add a file, justπmake a temp file called ADDED.DAT, write a byte value for the datacount,πand a word value for the filesize of the data you're adding, and thenπthe data. Hope this help all of you who wanted to be able to add ANSis,πGIFs, and whatnot onto exes. Also, with little modification, you canπmake it read from .DAT files with multiple gifs and stuff in them.π}π 32 08-27-9320:55ALL GABE KRUPA Modify EXE constants IMPORT 65 èo (*πGABE KRUPAππ> I need to add some information to the end of an EXE file and be ableπ> Say a PCX image for example. I'm concerned about the EXE file alreadπ> open due to being executed. Does info tacked to the end of an EXE geπ> into memory automatically, etc. I haven't tried this yet but am abouπ> hoping someone who has tried it can assist me to avoid some of the piπ> they may have encountered. Thanks. (BTW, I am experienced in Pas &ππ Well, I made a unit for that purpose, but my unit only tacks on 1K ofπstorage space... You can make it as large as you want it, but it'll be aπREAL time consumer and it might push your text editor to the limits (I'mπnot sure if the IDE has a file size limit).ππ Here it is (in a VERY shortened version )π}πunit inject1k;ππinterfaceπimplementationπconst doesnt_matter_what_this_is_called : boolean = false;ππprocedure never_really_call_this_procedure;πbeginπ if doesnt_matter_what_this_is_called thenπ inline( 228/229/230/231/231/233/234/ { this I use for a ID string }π 234/234/234/234/234/234/234/π 234/234/234/234/243/234/234/π{ repeat as many times until you get enough .. each '234/' is 1 byte }π 234/234/234/234/234/234/234/π 234/234/234/234/234/234/234/ { this is the actual 'junk' }π ); { inline }πend; { procedure }ππend. { unit }π{π I only inject 1024 into my EXE file... If you want, you can makeπidentical units like that, but the DATA area will NOT be in one longπstring unless all the bytes are in one unit.π I use the ID string to correctly place the file pointer. Just open theπEXE, read in bytes until you get a 228. Read another, if it's a 229πetc.. Keep looping until you get a 228-229-230-231-232-233-234 and thenπyou can start reading/writing. It's by no means the easiest way, but Iπprefer it over trying to append to the end. I tried that, but I keptπgetting errors and such. As long as the PCX file is fairly small, youπwon't have too much of a problem.π I'm not sure what the chances are, they must be pretty slim to find aπstring (228-234) one after the other in an EXE. If you think they areπhigher, or whatever, just put your own in. You could probably even putπtext in like this:π}πinline('D'/'A'/'T'/'A'/' '/'S'/'T'/'A'/'R'/'T'/'S'/' '/'H'/'E'/'R'/'E'/π111/111/111/111 { etc... } );π{π I hope this helps, or gives you some ideas. Note, the unit willπbe about TWICE as large as the number of bytes you inject (maybe 1000πmore), but the EXE will only increse by the number you add. I'm prettyπsure that the extra bytes are just data/debug info in the TPU file.π*)ππ{πMARK LEWISππ> I need to add some information to the end of an EXE file and be ableπ> Say a PCX image for example. I'm concerned about the EXE file alreadππ[... trim ...]ππ> Well, I made a unit for that purpose, but my unit only tacks onπ> 1K of storage space... You can make it as large as you want it,π> but it'll be a REAL time consumer and it might push your textπ> editor to the limits (I'm not sure if the IDE has a file sizeπ> limit). Here it is (in a VERY shortened version )π> unit inject1k;ππ[... trim ...]ππinteresting<<smile>>... i never thought of doing it like that.. hehe.. here'sπa unit i got from this echo or the other PASCAL echo several years ago.. i'veπused it in self-limiting programs (ones that only run a certain number ofπtimes) and other programs that may be subject to hacking of various forms...πi've modified it slightly for my purposes...π}πunit selfmod;ππ{ Allows a program to self modify a typed constant in the .exe file. It }π{ also performs an automatic checksum type .exe file integrity check. }π{ A longint value is added to the end of the exe file. This can be read by }π{ a separate configuration program to enable it to determine the start of }π{ the programs configuration data area. To use this the configuration }π{ typed constant should be added immediately following the declaration of }π{ ExeData. }π{ Where this unit is used, it should always be the FIRST unit listed in the }π{ uses declaration area of the main program. }π{ Requires DOS 3.3 or later. Program must not be used with PKLite or LZExe }π{ or any similar exe file compression programs. }π{ The stack size needed is at least 9,000 bytes. }ππinterfaceππtypeπ ExeDatatype = recordπ IDStr : string[8];π FirstTime : boolean;π Hsize : word;π ExeSize : longint;π CheckSum : longint;π StartConst : longint;π end;ππconstπ ExeData : ExeDatatype = (IDStr : 'IDSTRING';π FirstTime : true;π Hsize : 0;π ExeSize : 0;π CheckSum : 0;π StartConst: 0);ππ{ IMPORTANT: Put any config data typed constants here }ππprocedure Write2Exec(var data; size: word);ππ{============================================================================}ππimplementationππprocedure InitConstants;π varπ f : file;π tbuff : array[0..1] of word;ππ function GetCheckSum : longint;π { Performs a checksum calculation on the exe file }π varπ finished : boolean;π x,π CSum : longint;π BytesRead : word;π buffer : array[0..4095] of word;π beginπ {$I-}π seek(f,0);π finished := false; CSum := 0; x := 0;π BlockRead(f,buffer,sizeof(buffer),BytesRead);π while not finished do begin { do the checksum calculations }π repeat { until file has been read up to start of config area }π inc(CSum,buffer[x mod 4096]);π inc(x);π finished := ((x shl 1) >= ExeData.StartConst);π until ((x mod 4096) = 0) or finished;π if not finished then { data area has not been reached }π BlockRead(f,buffer,sizeof(buffer),BytesRead);π end;π GetCheckSum := CSum;π end;ππ beginπ assign(f, ParamStr(0));π {$I-} Reset(f,1);π with ExeData do beginπ if FirstTime and (IOResult = 0) then beginπ Seek(f,2); { this location has the executable size }π BlockRead(f,tbuff,4);π ExeSize := tbuff[0]+(pred(tbuff[1]) shl 9);π seek(f,8); { get the header size }π BlockRead(f,hsize,2);π FirstTime := false;π StartConst := longint(hsize+Seg(ExeData)-PrefixSeg) shl 4 +π Ofs(ExeData) - 256;π CheckSum := GetCheckSum;π Seek(f,StartConst);π BlockWrite(f,ExeData,sizeof(ExeData));π seek(f,FileSize(f));π BlockWrite(f,StartConst,4);π endπ elseπ if GetCheckSum <> CheckSum then beginπ writeln;π writeln(#7,#7,'Program file has been UNLAWFULLY modified!',#7,#7);π writeln;π writeln('It may have a Virus attached or someone may have made');π writeln('an attempt to HACK it. You should check your system for');π writeln('virus'' before continuing....');π writeln;π writeln('Please reinstall the .EXE file from the original archive.');π writeln('Aborting....');π halt(255);π endπ elseπ beginπ writeln;π writeln('Integrity Validated.');π end;π end; { with }π Close(f); {$I+}π if IOResult <> 0 then beginπ writeln('Unable to initialise program');π halt;π end;π end; { InitConstants }ππprocedure Write2Exec(var data; size: word);π { writes a new typed constant into the executable file. }π varπ f : file;π beginπ assign(f, ParamStr(0));π {$I-} Reset(f,1);π Seek(f,longint(ExeData.Hsize+Seg(data)-PrefixSeg) shl 4 + Ofs(data)- 256);π BlockWrite(f,data,size);π Close(f); {$I+}π if IOResult <> 0 then;π end; { Write2Exec }ππbeginπ writeln('Please Standby...');π InitConstants;πend.ππ 33 08-27-9321:01ALL STEVE ROGERS True EXE Size IMPORT 12 èo {πSTEVE ROGERSππ> Also, does anyone know how PKware wrote the ZIP2EXE Program? I'm alsoπ>writing an encryption Program, and I thought a 'self-decrypting' Fileπ>would be neat, so I had some ideas on how to do it. Could you justπ>append the encrypted data to the end of a short 'stub' Program, whichπ>just seeks in how ever many Bytes and reads from there? Or would Iπ>have to somehow assign all the data to a few Typed Constants?ππJust so happens I have been dealing With the same problem. I haveπwritten a Procedure to show the "True" size of an EXE File. Knowing thisπyou can easily get to your "data area" by seeking past the "True" size.ππ( Acknowledgements to Andy McFarland and Ray Duncan )π}ππFunction exesize(fname : String) : LongInt;πTypeπ t_size = Recordπ mz : Array [1..2] of Char;π remainder,π pages : Word;π end;ππVarπ f : File of t_size;π sz : t_size;ππbeginπ assign(f,fname);π {$i-}π reset(f);π {$i+} { io checking should be off }π if (ioresult <> 0) thenπ exesize:= 0π elseπ beginπ read(f,sz);π close(f);π With sz doπ exesize := remainder + (pred(pages) * 512);π end;πend;πππ{πThis thing reads the header of an EXE File and gets the info there. Iπwas amazed when I ran this on a bunch of progs and found how many haveπdata appended. Hope it helps. :)π} 34 08-27-9321:23ALL GERD KORTEMEYER Detect Float Error IMPORT 132 èo {πGERD KORTEMEYERππhere are two Units For trapping float-exceptions. In your Program youπwill have to addππ Uses err387ππand at the beginning of your main Program say For exampleππbeginπ exception(overflow, masked);π exception(underflow, dumpask);π exception(invalid, dumpexit);π autocorrect(zerodiv, 1.0);π exception(precision, masked);ππIn this way you can choose For any kind of exception in which way it isπto be handeled. After the lines above the result of a division by zeroπwill be '1.0', in Case of an underflow there will be a dump of the coproπand the user will be asked For the result he wants the operation to have,πin Case of an overflow the largest available number will be chosen andπso on ...ππHere are the Unitsππ err387 and dis387π}ππ{ ---------------------------------------------------------- }π{ Fehlerbehandlungsroutinen fuer den Intel 80387 bzw. 486 DX }π{ Geschrieben in Turbo Pascal 6.0 }π{ von Gerd Kortemeyer, Hannover }π{ ---------------------------------------------------------- }ππUnit err387;ππInterfaceππUsesπ dis387, Dos, Crt;ππConstπ invalid = 1;π denormal = 2;π zero_div = 4;π overflow = 8;π underflow = 16;π precision = 32;π stackfault= 64;π con1 = 512;ππ masked = 0;π runtime = 1;π dump = 2;π dumpexit = 3;π dumpask = 4;π autocorr = 5;πππProcedure exception(which, what : Word);πProcedure autocorrect(which : Word; by : Extended);ππProcedure handle_off;πProcedure handle_on;ππProcedure restore_masks;ππProcedure clear_copro;πFunction status_Word : Word;ππVarπ do_again : Word;ππImplementationππConstπ valid = 0;π zero = 1;π spec = 2;π empty = 3;ππ topmask : Word = 14336;π topdiv = 2048;ππ anyerrors : Word = 63;ππ zweipot : Array [0..15] of Word =π (1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,π 2048, 4096, 8192, 16384, 32768);ππ ex_nam : Array[0..5] of String=π ('Invalid ',π 'Denormal ',π 'Zero-Div ',π 'Overflow ',π 'Underflow ',π 'Precision ');ππVarπ setmasks : Byte;π normal : Recordπ Case Boolean OFπ True : (adr : Pointer);π False: (pro : Procedure);π end;ππ Exit_on,π dump_on,π ask_on,π auto_on,π standard : Word;ππ auto_val : Array [0..5] of Extended;ππProcedure Mask(which : Word);πVarπ cw : Word;πbeginπ Asmπ fstcw cwπ end;π cw := cw or which;π setmasks := Lo(cw);π Asmπ fldcw cwπ end;πend;ππProcedure Unmask(which : Word);πVarπ cw : Word;πbeginπ Asmπ fclexπ fstcw cwπ end;π cw := cw and not (which);π setmasks := Lo(cw);π Asmπ fldcw cwπ end;πend;ππProcedure restore_masks;πVarπ setm : Word;π i :Integer;πbeginπ setm:=setmasks;π For i := 0 to 5 doπ if (setm and zweipot[i]) <> 0 thenπ Mask (zweipot[i])π elseπ Unmask(zweipot[i]);πend;ππProcedure clear_copro;πVarπ cw : Word;πbeginπ Asmπ fstcw cwπ end;π setmasks := Lo(cw);π Asmπ finitπ end;πend;ππFunction status_Word;πbeginπ Asmπ fstsw @resultπ end;πend;ππ{ Bei welcher Exception soll was passieren? }πProcedure exception;πbeginπ Case what OFππ masked : Mask(which);ππ runtime :π beginπ Unmask(which);π standard := standard or which;π end;ππ dump :π beginπ Unmask(which);π standard := standard and NOT(which);π dump_on := dump_on or which;π Exit_on := Exit_on and NOT(which);π ask_on := ask_on and NOT(which);π auto_on := auto_on and NOT(which);π end;ππ dumpexit :π beginπ Unmask(which);π standard := standard and NOT(which);π dump_on := dump_on or which;π Exit_on := Exit_on or which;π ask_on := ask_on and NOT(which);π auto_on := auto_on and NOT(which);π end;ππ dumpask :π beginπ Unmask(which);π standard := standard and NOT(which);π dump_on := dump_on or which;π Exit_on := Exit_on and NOT(which);π ask_on := ask_on or which;π auto_on := auto_on and NOT(which);π end;π end;πend;ππ{ zum Setzen von Auto-Korrekt-Werten }ππProcedure autocorrect;πVarπ i : Integer;πbeginπ Unmask(which);π standard := standard and NOT(which);π dump_on := dump_on and NOT(which);π Exit_on := Exit_on and NOT(which);π ask_on := ask_on and NOT(which);π auto_on := auto_on or which;π For i := 0 to 5 doπ if (which and zweipot[i]) <> 0 thenπ auto_val[i] := by;πend;ππ{ ------------- Die Interrupt-Routine selbst ------------- }ππProcedure errorcon; Interrupt;πVarπ copro : Recordπ control_Word,π status_Word,π tag_Word, op,π instruction_Pointer,π ip, operand_Pointer, : Word;π st : Array [0..7] of Extended;π end;ππ top : Integer; { welches Register ist Stacktop? }ππ masked, { welche Exceptions maskiert? }π occured : Byte; { welche Exceptions aufgetreten? }ππ opcode : Word;ππ inst_seg, { Instruction-Pointer, Segment }π inst_off, { " , Offset }π oper_seg, { Operand-Pointer , Segment }π oper_off: Word; { " , Offset }ππ inst_point : ^Word; { zum Adressieren des Opcodes }ππ oper_point : Recordπ Case Integer of { zum Adressieren des Operanden }π 1 : (ex : ^Extended);π 2 : (db : ^Double);π 3 : (si : ^Single);π 4 : (co : ^Comp);π end;ππ marker: Array [0..7] of Word; { Register-Marker nach Tag-Word }ππ opt_dump, { soll ausgeben werden? }π opt_exit, { soll aufgehoert werden? }π opt_ask, { soll Ergebnis abgefragt werden? }π opt_auto : Boolean; { soll Ergebnis automatisch korrigiert werden? }ππ i : Integer;ππ mem_access: Boolean; { gibt es Speicherzugriff? }ππ op_name : String; { Mnemonik des Befehls }ππ{ Ersetze Stacktop durch abgefragten Wert }πProcedure ask_correct;πVarπ res : Extended;π ch : Char;π t : String;π code : Integer;πbeginπ Asmπ fstp resπ end;π WriteLN;π Write('The result would be ', res, '. Change? (y/n) ' );π Repeatπ Repeat Until KeyPressed;π ch := ReadKey;;π Until ch in ['Y','y','N','n'];π Writeln;π if ch in ['Y','y'] thenπ Repeatπ Write('New value : ');π READLN(t);π VAL(t, res, code);π Until code = 0;π Asmπ fld resπ end;πend;ππFunction hex(w : Word) : String; { Ausgabe als HeX-Zahl }πConstπ zif : Array [0..15] of Char = ('0','1','2','3','4','5','6','7','8','9',π 'a','b','c','d','e','f');πbeginπ hex := zif[w div zweipot[12]] +π zif[(w MOD zweipot[12]) div zweipot[8]] +π zif[(w MOD zweipot[8]) div zweipot[4]] +π zif[w MOD zweipot[4]];πend;ππProcedure choice;πVarπ ch : Char;πbeginπ WriteLN;π Write('C)ontinue, A)bort ');π Repeatπ Repeat Until KeyPressed;π ch:=ReadKey;;π if ch in ['A','a'] thenπ Halt(0);π Until ch in ['C','c'];π WriteLN;πend;ππProcedure showcopro; { Ausgeben des FSAVE - Records }πVarπ i : Integer;πbeginπ TextMode(LastMode);π HighVideo;π WriteLN('Floating point exception, last opcode: ',hex(opcode),π ' (',op_name,')');π NormVideo;π WriteLN('Instruction Pointer : ',hex(inst_seg),':',hex(inst_off),π ' (',hex(inst_point^),')');π if mem_access thenπ beginπ WriteLN('Operand Pointer : ',hex(oper_seg),':',hex(oper_off));π WriteLN('( Extended: ',oper_point.ex^,', Double: ',oper_point.db^);π WriteLN(' Single : ',oper_point.si^,', Comp : ',oper_point.co^,' )');π endπ elseπ beginπ WriteLN;π WriteLN ('No memory access');π WriteLN;π end;π HighVideo;π if (occured and stackfault) = 0 thenπ beginπ WriteLN('Exception ','Masked':8,'Occured':8,'Should be masked':18);π NormVideo;π For i:=0 to 5 doπ WriteLN(ex_nam[i], (masked and zweipot[i]) <> 0 : 8,π (occured and zweipot[i]) <> 0 : 8,π (setmasks and zweipot[i]) <> 0 : 18);π HighVideo;π endπ elseπ beginπ WriteLN('Invalid Operation:');π if (copro.status_Word and con1) <> 0 thenπ WriteLN(' -- Stack Overflow --')π elseπ WriteLN(' -- Stack Underflow --');π WriteLN;π end;ππ WriteLN('Reg ','Value':29,'Marked':10);π Normvideo;π For i := 0 to 7 doπ beginπ Write('st(',i,')', copro.st[i] : 29);π Case marker[i] OFπ valid : WriteLN('Valid' : 10);π spec : WriteLN('Special' : 10);π empty : WriteLN('Empty' : 10);π zero : WriteLN('Zero' : 10);π end;π end;πend;ππ{ Ersetze Stacktop durch Auto-Korrekt-Wert }ππProcedure auto_corr;πVarπ res : Extended;π i : Integer;πbeginπ Asmπ fstp resπ end;π For i := 0 to 5 doπ if ((occured and zweipot[i]) <> 0) andπ ((auto_on and zweipot[i]) <> 0) thenπ res := auto_val[i];π Asmπ fld resπ end;πend;πππProcedure do_it_again;πTypeπ codearr = Array[0..4] of Byte;πVarπ sam : Recordπ Case Boolean OFπ True : (b: ^codearr );π False: (p: Procedure);π end;ππ op_point : Pointer;π x : extended;πbeginπ New(sam.b);π sam.b^[0]:=Hi(opcode);π sam.b^[1]:=Lo(opcode);π if mem_access thenπ beginπ { --- mod r/m auf ds:[di] stellen (00ttt101) --- }π sam.b^[1] := sam.b^[1] and not (zweipot[7] + zweipot[6] + zweipot[1]);π sam.b^[1] := sam.b^[1] or (zweipot[2] + zweipot[0]);π end;π sam.b^[2] := $ca; { retf 0000 }π sam.b^[3] := $00;π sam.b^[4] := $00;π op_point := oper_point.ex;π Asmπ push dsπ lds di, op_pointπ end;ππ sam.p;ππ Asmπ pop dsπ end;π Dispose(sam.b);πend;ππbeginπ Asmπ push axπ xor al,alπ out 0f0h,alπ mov al,020hπ out 0a0h,alπ out 020h,alπ pop axπ fsave coproπ end;ππ { === Pruefen, ob Bearbeitung durch ERRORCON erwuenscht === }π if (copro.status_Word and standard) <> 0 thenπ beginπ Asmπ frstor coproπ end;π normal.pro; { Bye, bye ... }π end;π { === Auswerten des FSAVE-Records ========================= }π { --- Opcode wie im Copro gespeichert --- }π opcode := zweipot[15] + zweipot[14] + zweipot[12] + zweipot[11] +π (copro.ip MOD zweipot[11]);π op_name := dis(opcode);π mem_access := op_name='...';π { --- Was war maskiert, was ist passiert? --- }π masked := Lo(copro.control_Word);π occured := Lo(copro.status_Word );π { --- Der Instruction-Pointer --- }π inst_seg := copro.ip and (zweipot[15] + zweipot[14] + zweipot[13] +π zweipot[12]);π inst_off := copro.instruction_Pointer;π inst_point := Ptr(inst_seg,inst_off);π { --- Der Operand-Pointer --- }π oper_seg := copro.op and (zweipot[15] + zweipot[14] + zweipot[13] +π zweipot[12]);π oper_off := copro.operand_Pointer;π oper_point.ex := Ptr(oper_seg,oper_off);π { --- Wer ist gerade Stacktop? --- }π top := (copro.status_Word and topmask) div topdiv;π { --- Einlesen der Marker aus Tag-Word --- }π For i := 0 to 7 doπ beginπ marker[(8 + i - top) MOD 8] := (copro.tag_Word and (zweipot[i * 2] +π zweipot[i * 2 + 1])) div zweipot[i * 2];π end;ππ { --- Welche Aktionen sollen ausgefuehrt werden? --- }π opt_dump := (copro.status_Word and dump_on) <> 0;π opt_exit := (copro.status_Word and Exit_on) <> 0;π opt_ask := (copro.status_Word and ask_on ) <> 0;π opt_auto := (copro.status_Word and auto_on) <> 0;ππ { === Aktionen ============================================ }π if opt_dump thenπ showcopro;π if opt_exit thenπ beginπ WriteLN;π WriteLN('Exit Program due to Programmers request');π HALT; { Bye, bye ... }π end;π if opt_dump and not (opt_ask) thenπ choice;ππ copro.control_Word := copro.control_Word or anyerrors;π Asmπ frstor coproπ fclexπ end;π { --- Befehl nochmals ausfuehren --- }π if (occured and do_again) <> 0 thenπ do_it_again;π { --- Noch was? --- }π if opt_auto thenπ auto_corr;π if opt_ask thenπ ask_correct;π restore_masks;πend;ππ{ ------------- Ein- und Ausschalten ------------- }ππProcedure handle_on;πbeginπ Getintvec($75, normal.adr);π Setintvec($75, @errorcon);πend;ππProcedure handle_off;πbeginπ Setintvec($75, normal.adr);πend;ππbeginπ handle_on;π dump_on :=0;π Exit_on :=0;π ask_on :=0;π auto_on :=0;π standard:=0;π do_again:=invalid+zero_div+denormal;π clear_copro;πend.πππππππUnit dis387;ππInterfaceππFunction dis(opco : Word) : String;ππImplementationππFunction dis;πVarπ d, op : String;ππ Procedure opcr(st : Word);π Varπ t : String;π beginπ str(st, t);π op := ' st,st(' + t + ')';π end;ππ Procedure opc(st : Word);π Varπ t : String;π beginπ str(st, t);π op := ' st(' + t + '),st';π end;ππ Procedure op1(st : Word);π Varπ t : String;π beginπ str(st, t);π op := ' st(' + t + ')';π end;ππbeginπ d := '...';π op := '';ππ Case Hi(opco) OFπ $d8 :π Case Lo(opco) div 16 OFπ $c :π if opco MOD 16 >= 8 thenπ beginπ d := 'fmul';π opcr(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fadd';π opcr(opco MOD 16);π end;ππ $e :π if opco MOD 16 >= 8 thenπ beginπ d := 'fsubr';π opcr(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fsub';π opcr(opco MOD 16);π end;ππ $f :π if opco MOD 16 >= 8 thenπ beginπ d := 'fdivr';π opcr(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fdiv';π opcr(opco MOD 16);π end;π end;ππ $d9 :π Case Lo(opco) OFπ $d0 : d := 'fnop';π $e0 : d := 'fchs';π $e1 : d := 'fabs';π $e4 : d := 'ftst';π $e5 : d := 'fxam';π $e8 : d := 'fld1';π $e9 : d := 'fld2t';π $ea : d := 'fld2e';π $eb : d := 'fldpi';π $ec : d := 'fldlg2';π $ed : d := 'fldln2';π $ee : d := 'fldz';π $f0 : d := 'f2xm1';π $f1 : d := 'fyl2x';π $f2 : d := 'fptan';π $f3 : d := 'fpatan';π $f4 : d := 'fxtract';π $f5 : d := 'fprem1';π $f6 : d := 'fdecstp';π $f7 : d := 'fincstp';π $f8 : d := 'fprem';π $f9 : d := 'fyl2xp1';π $fa : d := 'fsqrt';π $fb : d := 'fsincos';π $fc : d := 'frndint';π $fd : d := 'fscale';π $fe : d := 'fsin';π $ff : d := 'fcos';π end;ππ $db :π Case Lo(opco) OFπ $e2 : d := 'fclex';π $e3 : d := 'finit';π end;π $dc :π Case Lo(opco) div 16 OFπ $c :π if opco MOD 16 >= 8 thenπ beginπ d := 'fmul';π opc(opco MOD 16-8);π endπ elseπ beginπ d := 'fadd';π opc(opco MOD 16);π end;ππ $e : if opco MOD 16 >= 8 thenπ beginπ d := 'fsub';π opc(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fsubr';π opc(opco MOD 16);π end;ππ $f :π if opco MOD 16 >= 8 thenπ beginπ d := 'fdiv';π opc(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fdivr';π opc(opco MOD 16);π end;π end;ππ $dd :π Case Lo(opco) div 16 OFπ $c :π beginπ d := 'ffree';π op1(opco MOD 16);π end;π $d :π if opco MOD 16 >= 8 thenπ beginπ d := 'fstp';π op1(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fst';π op1(opco MOD 16);π end;π $e :π if opco MOD 16 >= 8 thenπ beginπ d := 'fucomp';π op1(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fucom';π op1(opco MOD 16);π end;π end;ππ $de :π Case Lo(opco) div 16 OFπ $c :π if opco MOD 16 >= 8 thenπ beginπ d := 'fmulp';π opc(opco MOD 16 - 8);π endπ elseπ beginπ d := 'faddp';π opc(opco MOD 16);π end;ππ $d : d := 'fcompp';ππ $e :π if opco MOD 16 >= 8 thenπ beginπ d := 'fsubp';π opc(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fsubrp';π opc(opco MOD 16);π end;ππ $f :π if opco MOD 16 >= 8 thenπ beginπ d := 'fdivp';π opc(opco MOD 16 - 8);π endπ elseπ beginπ d := 'fdivrp';π opc(opco MOD 16);π end;π end;π end;ππ dis := d + op;πend;ππbeginπend.π 35 08-27-9321:40ALL SEAN PALMER Simple Multi-Tasker IMPORT 22 èo {π by Sean L. Palmerπ Public Domainππ This is a 'multitasking' Program in the sense that it hooks intoπ the timer interrupt, but what that interrupt ends up actuallyπ doing is controlled by the current value in SaveAdr, whichπ changes With each interrupt as the routine passes control backπ to the tick handler not by Exiting normally, but by an explicitπ transfer of control.π The end result of this is that you can Write a state-drivenπ interrupt handlerπ The included example is RealLY simplistic, and barely tested.π I intend to use this to Write a comm port driver thatπ parses the incoming data as it receives it which wouldπ be nice in a communications Program that shells to Dos, asπ the incoming Chars could be saved to disk in the backgroundπ With buffered ZModem or something...π}ππProgram intTest;ππUsesπ Dos;ππVarπ saveAdr : Word; {offset in this code segment of where we are now}π active : Boolean; {to avoid re-entrancy}ππProcedure intHandler; Far; Assembler;πAsmπ pushaπ mov ax, seg @DATAπ mov ds, axππ {anything you need to do before continuing (reading port data?), do here}ππ in al, $61 {click speaker as an example}π xor al, 2π out $61, alππ test active, $FF {exit now if interrupted ourselves}π jz @OKπ popaπ iretππ @OK:π inc Byte ptr activeπ stiπ jmp [saveAdr] {near jump to continue where handler last left off}πend;ππ{call this Procedure from StateHandler to suspend execution Until next time}ππProcedure wait; near; Assembler;πAsm {wait For next interrupt}π pop Word ptr saveAdr {save where to continue next time}π dec Byte ptr activeπ popa {restore caller regs}π iretπend;ππConstπ c : Char = '.';ππProcedure stateHandler;πbeginπ{π a stateHandler Procedure should never ever Exit (only by calling 'wait'),π shouldn't have any local Variables or parameters, and shouldn't callπ 'wait' With anything on the stack (like from a subroutine).π This routine is using the caller's (interrupted Program's) stack, so beπ very very careful}ππ Asmπ pop bp {clean up stack mess left by Turbo's Procedure header}π end;π {^ alternative method here is to init saveAdr to offset(proc)+3 and skipπ the push bp; mov bp,sp altogether}ππ Repeat {this is an example only}π c := '@';π wait;π c := '.';π wait;π Until False; {don't let it return normally!!}πend;ππVarπ oldHook : Procedure;π i : Integer;ππbeginπ saveAdr := ofs(stateHandler);π getIntVec($1C, @oldHook);π setIntVec($1C, @intHandler);π For i := 1 to 1500 doπ Write(c);π setIntVec($1C, @oldHook);πend.πππ 36 08-27-9322:12ALL DAVID DOTY Writing To EXE File IMPORT 73 èo {π> How are you saaving the CFG into the .EXE?? Mind posting some code that wilπ> save the CFG to the EXE?(When you get all your bugs fixed!)ππI use these routines in my self-modifying .EXE's. They work pretty good.π}ππUnit WritExec;ππ { ==================================================================ππ Unit: WritExecπ Author: David Dotyπ Skipjack Softwareπ Columbia, Marylandπ CompuServe User I.D.: 76244,1043ππ This Unit is based on a previously published Program:ππ Program: AutoInst v2.0π Author: David Duboisπ Zelkop Softwareπ Halifax, Nova Scotiaπ CompuServe User I.D.: 71401,747π Date last revised: 1988.04.24ππ ==================================================================ππ This source code is released to the public domain. if further changesπ are made, please include the above credits in the distributed code.ππ This Unit allows a Program to change the value of a Typed Constant in itsπ own .EXE File. When the Program is run again, the data will be initializedπ to the new value. No external configuration Files are necessary.ππ Usesππ Examples of the usefulness of this technique would be:ππ o A Program that allows the user to change default display colors.ππ o A Program that keeps track of a passWord that the user can change.ππ HOW IT WORKSππ You don't have to understand all the details in order to use thisπ technique, but here they are.ππ The data to be changed must be stored in a TurboPascal Typedπ Constant. In all effect, a Typed Constant is actually a pre-π initialized Variable. It is always stored in the Program's Dataπ Segment. The data can be of any Type.ππ First, the Procedure finds the .EXE File by examining the Dos commandπ line, stored With the copy of the Dos environment For the Program. Thisπ allows the Program to find itself no matter where is resides on disk andπ no matter how its name is changed by the user.ππ The unTyped File is opened With a Record size of 1. This allows usπ to read or Write a String of Bytes using BlockRead and BlockWrite.ππ As documented in the Dos Technical Reference, the size of the .EXEπ header, in paraGraphs (a paraGraph is 16 Bytes), is stored as aπ two-Byte Word at position 8 of the File. This is read into theπ Variable HeaderSize.ππ The next step is to find the position of the Typed Constant in theπ .EXE File. This requires an understanding of the Turbo Pascal 4.0π memory map, documented on the first and second pages of the Insideπ Turbo Pascal chapter. (That's chapter 26, pages 335 and 336 in myπ manual.)ππ First, find the address in memory where the Typed Constant isπ stored. This can be done in Turbo Pascal by using the Seg and Ofsπ Functions. Next find the segment of the PSP (Program segmentπ prefix). This should always be the value returned by PrefixSeg.π That will mark the beginning of the Program in memory. Theπ position of the Typed Constant in the .EXE image should be theπ number of Bytes between these two places in memory. But ...ππ But, two corrections must be made. First, the PSP is not stored inπ the .EXE File. As mentioned on page 335, the PSP is always 256π Bytes. We must subtract that out. Secondly, there is the .EXE Fileπ header. The size of this has already been read in and must beπ added in to our calculations.ππ Once the position has been determined, the data stored in theπ Typed Constant is written in one fell swoop using a BlockWrite.π This replaces the original data, so that the next time the Programπ is run, the new values will used.ππ LIMITATIONSππ You cannot use MicroSoft's EXEPACK on the .EXE File, or any otherπ packing method I know of. This may change the position, or evenπ the size of the Typed Constant in the File image.ππ NOTESππ Since Typed Constants are always stored in the data segment, theπ Function call to Seg( ObjectToWrite ) can be replaced With DSeg. Iπ prefer using Seg since it is more descriptive.ππ One might think that Cseg can used as an alternative to usingπ PrefixSeg and subtracting 256. This will work only if the codeπ resides in the main Program. If, on the other hand, the code isπ used in a Unit, PrefixSeg must be used as described here. Youπ might as well use PrefixSeg and save yourself some headaches.ππ if you have any comments or questions we would be glad to hearπ them. if you're on CompuServe, you can EasyPlex a letter toπ 76244,1043 or 71401,747. Or leave a message on the Borland Programmer's Aπ Forum (GO BPROGA). Or, you can Write toππ Skipjack Softwareπ P. O. Box 61π Simpsonville Maryland 21150ππ orππ Zelkop Softwareπ P.O. Box 5177π Armdale, N.S.π Canadaπ B3L 4M7ππ ==================================================================}πππInterfaceππFunction GetExecutableName : String;π{ This Function returns the full drive, path, and File name of the applicationπ Program that is running. This Function is of more general interest thanπ just For writing into the EXE File.ππ NOTE: THIS Function WILL ONLY WORK UNDER Dos 3.X + !!! }ππFunction WriteToExecutable(Var ObjectToWrite; ObjectSize : Word) : Integer;π{ This Procedure modifies the EXE File on disk to contain changes to Typedπ Constants. NOTE - the Object MUST be a Typed Constant. It may be foundπ in any part of the Program (i.e., main Program or any Unit). The call isπ made by unTyped address, to allow any kind of Object to be written. Theπ Function returns the Dos error code from the I/O operation that failedπ (if any did); if all operations were successful, the Function returns 0. }ππImplementationππFunction GetExecutableName : String;πTypeπ Environment = Array[0..32766] of Char;πConstπ NullChar : Char = #0;π SearchFailed = $FFFF;πVarπ MyEnviron : ^Environment;π Loop : Word;π TempWord : Word;π EnvironPos : Word;π FilenamePos : Word;π TempString : String;πbegin { Function GetExecutableName }π { Get Pointer to Dos environment }π MyEnviron := Ptr(MemW[PrefixSeg : $2C], 0);ππ { Look For end of environment }π EnvironPos := SearchFailed;π Loop := 0;ππ While Loop <= 32767 DOπ beginπ if MyEnviron^[ Loop ] = NullChar thenπ if MyEnviron^[ Loop + 1 ] = NullChar thenπ begin { found two nulls - this is end of environment }π EnvironPos := Loop;π Loop := 32767π end; { found two nulls }π Inc(Loop);π end; { While Loop }ππ if EnvironPos = SearchFailed thenπ GetExecutableName := ''π elseπ begin { found end of environment - now look For path/File of exec }π EnvironPos := EnvironPos + 4;π FilenamePos := SearchFailed;π TempWord := EnvironPos;π Loop := 0;ππ While Loop <= 127 DOπ beginπ if MyEnviron^[TempWord] = NullChar thenπ begin { found a null - this is end of path/File of exec }π FilenamePos := Loop;π Loop := 127π end; { found a null }π Inc(Loop);π Inc(TempWord);π end; { While Loop }ππ if FilenamePos = SearchFailed thenπ GetExecutableName := ''π elseπ begin { found executable name - move into return String }π TempString[0] := Chr(FilenamePos);π Move(MyEnviron^[EnvironPos], TempString[1], FilenamePos);π GetExecutableName := TempString;π end; { found executable name }π end; { found environment end }πend; { Function GetExecutableName }πππFunction WriteToExecutable(Var ObjectToWrite; ObjectSize : Word ) : Integer;πConstπ PrefixSize = 256; { number of Bytes in the Program Segment Prefix }πVarπ Executable : File;π HeaderSize : Word;π ErrorCode : Integer;πbeginπ Assign(Executable, GetExecutableName);π {$I-}π Reset(Executable, 1);π ErrorCode := IOResult;ππ if ErrorCode = 0 thenπ begin { seek position of header size in EXE File }π Seek(Executable, 8);π ErrorCode := IOResult;π end; { seek header }ππ if ErrorCode = 0 thenπ begin { read header size in EXE File }π BlockRead(Executable, HeaderSize, SizeOf(HeaderSize));π ErrorCode := IOResult;π end; { read header }ππ if ErrorCode = 0 thenπ begin { seek position of Object in EXE File }π Seek(Executable,π LongInt(16) * (HeaderSize + Seg(ObjectToWrite) - PrefixSeg) +π Ofs(ObjectToWrite) - PrefixSize);π ErrorCode := IOResult;π end; { Seek Object position in File }ππ if ErrorCode = 0 thenπ begin { Write new passWord in EXE File }π BlockWrite(Executable, ObjectToWrite, ObjectSize);π ErrorCode := IOResult;π end; { Write new passWord }ππ Close(Executable);π WriteToExecutable := ErrorCode;ππend; { Function WriteToExecutable }ππend. { Unit WritExec }π
