leilabd@syma.sussex.ac.uk (Leila Burrell-Davis) (04/11/89)
I would like to pass to a program the full pathname of a file whose location I give relative to the current directory. For example, if I am in directory C:\SUBA\SUB1 and give the command FOO ..\SUB2\MYFILE.EXT I would like FOO to issue the command MYPROG C:\SUBA\SUB2\MYFILE.EXT for preference, although MYPROG C:\SUBA\SUB1\..\SUB2\MYFILE.EXT would probably be ok as well. Can anyone suggest how I might do this? -- Leila Burrell-Davis, Computing Service, University of Sussex, Brighton, UK Tel: +44 273 678390 Fax: +44 273 678335 JANET: leilabd@uk.ac.sussex.syma ARPA: leilabd%syma.sussex.ac.uk@cunyvm.cuny.edu BITNET: leilabd@syma.sussex.ac.uk UUCP: leilabd@syma.uucp
nelson@sun.soe.clarkson.edu (Russ Nelson) (04/13/89)
Written for Turbo C. I can't remember if I wrote this or if it's based
on some anonymous code from the IBMPC-Digest.
-russ
#include <string.h>
#include <ctype.h>
#include <dos.h>
#include <dir.h>
/*** rootpath -- convert a pathname argument to root based cannonical form
*
* rootpath determines the current directory, appends the path argument (which
* may affect which disk the current directory is relative to), and qualifies
* "." and ".." references. The result is a complete, simple, path name with
* drive specifier.
*
* If the relative path the user specifies does not include a drive spec., the
* default drive will be used as the base. (The default drive will never be
* changed.)
*
* entry: relpath -- pointer to the pathname to be expanded
* fullpath -- must point to a working buffer, see warning
* exit: fullpath -- the full path which results
* return: true if an error occurs, false otherwise
*
* calls: getcurdir getdisk
*
* warning: fullpath must point to a working buffer large enough to hold the
* longest possible relative path argument plus the longest possible
* current directory path.
*
*/
int rootpath(char *relpath, char *fullpath)
{
int drivenum ;
char tempchar;
register char *lead, *follow ;
/* extract drive spec */
if ((*relpath != '\0') && (relpath[1] == ':')) {
drivenum = toupper(*relpath) - 'A' ;
relpath += 2 ;
} else drivenum = getdisk() ;
fullpath[0] = (char) ('A' + drivenum) ;
fullpath[1] = ':' ;
/* append relpath to fullpath/base */
if (*relpath == '\\' || *relpath == '/') {
/* relpath starts at base */
strcpy(fullpath+2, relpath) ;
} else {
/* must get base path first */
fullpath[2] = '\\';
if (getcurdir(drivenum+1, fullpath+3))
return 1; /* terrible error */
if ((*relpath != '\0') && (strlen(fullpath) > 3))
strcat(fullpath, "\\") ;
strcat(fullpath, relpath) ;
}
/* convert path to cannonical form */
lead = fullpath ;
while(*lead != '\0') {
/* mark next path segment */
follow = lead ;
if ((lead = strchr(follow+1, '\\')) != '\0') {
char *fslash;
tempchar = '\\';
if ((fslash = strchr(follow+1, '/')) != '\0') {
if (fslash < lead) lead = fslash;
}
}
else if ((lead = strchr(follow+1, '/')) != '\0') tempchar = '\\';
else {
lead = fullpath + strlen(fullpath) ;
tempchar = '\0';
}
*lead = '\0';
/* "." segment? */
if (strcmp(follow+1, ".") == 0) {
*lead = tempchar ;
strcpy(follow, lead); /* remove "." segment */
lead = follow ;
}
/* ".." segment? */
else if (strcmp(follow+1, "..") == 0) {
*lead = tempchar ;
do {
if (--follow < fullpath)
return 1;
} while (*follow != '\\') ;
strcpy(follow, lead); /* remove ".." segment */
lead = follow ;
}
/* normal segment */
else
*lead = tempchar ;
}
if (strlen(fullpath) == 2) /* 'D:' or some such */
strcat(fullpath, "\\") ;
/* shift to upper case */
strupr(fullpath) ;
return 0;
}
#ifdef DEBUG
void main(int argc, char *argv[])
{
char fullpath[64];
if (argc != 2) cputs("usage: rootpath pathname");
else {
rootpath(argv[1], fullpath);
cputs(fullpath);
}
}
#endif
--
--russ (nelson@clutx [.bitnet | .clarkson.edu])
America -- Socialism for the rich people, Capitalism for the rest of us.
- Michael Harrington, Co-Chair, Democratic Socialists of Americafs-info@sbsvax.UUCP (Fachschaft Mathe/Info) (04/13/89)
In article <883@syma.sussex.ac.uk>, leilabd@syma.sussex.ac.uk (Leila Burrell-Davis) writes: > I would like to pass to a program the full pathname of a file > whose location I give relative to the current directory. For > example, if I am in directory C:\SUBA\SUB1 and give the command > FOO ..\SUB2\MYFILE.EXT try a change directory to the specified relative path (possibly stripping a trailing filename, and remember the old dir), and then issue a get current work directory - this will (as far as I know) always return a full pathname (including the drive, I think). > Can anyone suggest how I might do this? Hope I could. /* * Brian o'Fish * c/o Patrick Schaaf * Alter Stadtweg 69 * D-6602 Dudweiler/Saar * GERMANY * * X.400: fs-info@sbsvax.informatik.uni-saarland.dbp.de */
bkbarret@sactoh0.UUCP (Brent K. Barrett) (04/14/89)
In article <883@syma.sussex.ac.uk>, leilabd@syma.sussex.ac.uk (Leila Burrell-Davis) writes: > I would like to pass to a program the full pathname of a file > whose location I give relative to the current directory. For > example, if I am in directory C:\SUBA\SUB1 and give the command > FOO ..\SUB2\MYFILE.EXT > I would like FOO to issue the command MYPROG C:\SUBA\SUB2\MYFILE.EXT > for preference, although MYPROG C:\SUBA\SUB1\..\SUB2\MYFILE.EXT > would probably be ok as well. For what language and what type of application? If it's in C, it's a trivial matter. If in BASIC or some other language I'm not familiar with on the PC then I'm afraid I can't help you. If in C, just grab the current working directory (getcwd()), and appen the path supplied as an argument (adding a backslash if needed). -- "Thanks, Data; I noticed." Brent Barrett ..pacbell!sactoh0!bkbarret GEMAIL: B.K.BARRETT
abcscnuk@csuna.csun.edu (Naoto Kimura) (04/22/89)
In article <716@sbsvax.UUCP> fs-info@sbsvax.UUCP (Fachschaft Mathe/Info) writes: >In article <883@syma.sussex.ac.uk>, leilabd@syma.sussex.ac.uk (Leila Burrell-Davis) writes: >> I would like to pass to a program the full pathname of a file >> whose location I give relative to the current directory. For >> example, if I am in directory C:\SUBA\SUB1 and give the command >> FOO ..\SUB2\MYFILE.EXT > >try a change directory to the specified relative path (possibly stripping >a trailing filename, and remember the old dir), and then issue a get current >work directory - this will (as far as I know) always return a full pathname >(including the drive, I think). > >> Can anyone suggest how I might do this? > >Hope I could. > >/* > * Brian o'Fish > * c/o Patrick Schaaf > * Alter Stadtweg 69 > * D-6602 Dudweiler/Saar > * GERMANY > * > * X.400: fs-info@sbsvax.informatik.uni-saarland.dbp.de > */ Oh no !!! Here I go again posting Turbo pascal source ! The following unit files are included: dossvc, mymath, mystr The function to look at is FExpand in the file dossvc.pas ---- CUT HERE -------- CUT HERE -------- CUT HERE -------- CUT HERE ---- unit DosSvc; (*====================================================================*\ || MODULE NAME: DosSvc || || DEPENDENCIES: System.TPU, Dos.TPU, MyStr.TPU, PtrMath.TPU || || LAST MOD ON: 8904.07 || || PROGRAMMER: Naoto Kimura || || || || DESCRIPTION: This is a library of DOS service routines. || || Included in this unit are tools for: || || Getting string form of date and time || || Obtaining name of executed program || || Obtaining values of environment variables || || Followig MCB chain || \*====================================================================*) {$S+} {Stack checking on} {$I-} {I/O checking off} {$N-} {No numeric coprocessor} Interface Uses Dos, MyStr, PtrMath; const DIR_SEPARATOR = '\'; ALT_DIR_SEPARATOR = '/'; DSK_SEPARATOR = ':'; {$IFDEF VER40} DIR_CHARS : CharSet = ['/','\']; DOS_SEP_CHARS : CharSet = ['/','\',':']; {$ELSE} DIR_CHARS : CharSet = [DIR_SEPARATOR, ALT_DIR_SEPARATOR]; DOS_SEP_CHARS : CharSet = [DIR_SEPARATOR, ALT_DIR_SEPARATOR, DSK_SEPARATOR]; {$ENDIF} MonthName : array [1..12] of string[3] = ( 'Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec' ); DayWeekName : array [0..6] of string[3] = ( 'Sun','Mon','Tue', 'Wed','Thu','Fri','Sat' ); (*--------------------------------------------------------------------*\ | NAME: DateString | | | | This function will return the string representation of the | | information in the DateTime record type. | \*--------------------------------------------------------------------*) function DateString ( DT : DateTime ) : string; (*--------------------------------------------------------------------*\ | NAME: GetSwitchChar | | | | This function will return the switch character (the character | | used to specify options) set in DOS. | \*--------------------------------------------------------------------*) function GetSwitchChar : char; (*--------------------------------------------------------------------*\ | NAME: SetSwitchChar | | | | This function will set the switch character (the character | | used to specify options) set in DOS. | \*--------------------------------------------------------------------*) procedure SetSwitchChar ( c : char ); (*--------------------------------------------------------------------*\ | NAME: FixDirChars | | | | This function transforms the forward slash character ('/') into | | the backward slash character ('\') because version 5.0 of Turbo | | Pascal will do strange things if it finds the forward slash instead | | of the backward slash in a pathname. | \*--------------------------------------------------------------------*) function FixDirChars ( Original : string ) : string; {$IFDEF VER40} type ComStr = string[127]; PathStr = string[79]; DirStr = string[67]; NameStr = string[8]; ExtStr = string[4]; (*--------------------------------------------------------------------*\ | NAME: FSplit | | | | This procedure splits a fully specified file name, and splits | | the filename into its components. | \*--------------------------------------------------------------------*) procedure FSplit ( Path : PathStr; var Dir : DirStr; var Name : NameStr; var Ext : ExtStr ); (*--------------------------------------------------------------------*\ | NAME: FExpand | | | | This function expands the file name to a fully qualified path | | file name. | \*--------------------------------------------------------------------*) function FExpand ( Path : PathStr ) : PathStr; {$ENDIF} const ExecName : NameStr = ''; (* file name of executable *) ExecPath : DirStr = ''; (* path to executable *) (*--------------------------------------------------------------------*\ | NAME: PathName | | | | This function returns the path portion of the full path filename.| | This function interprets both '/' and '\' as directory separators. | \*--------------------------------------------------------------------*) function PathName( full : string ) : string; (*--------------------------------------------------------------------*\ | NAME: BaseName | | | | This function returns the base portion of a full path filename. | | This function interprets both '/' and '\' as directory separators. | \*--------------------------------------------------------------------*) function BaseName( full : string ) : string; (*--------------------------------------------------------------------*\ | NAME: File_Exists | | | | This boolean function returns TRUE if the file exists. | \*--------------------------------------------------------------------*) function File_Exists( s : string ) : boolean; type (*----------------------------------------------------------------*\ | The following record type describes the contents of the Program | | Segment Prefix (PSP). | | | | int20H exit code | | TopOfMemory Memory size in paragraphs | | Reserved0 ??? (0) | | PSP_DOS Far call to DOS | | TerminationAddr Terminate address | | BreakExitAddr Address of break handler | | CriticalErrorAddr Address of critical error handler | | ParentPSP_Seg Parent PSP segment | | OpenFiles Open files, $ff = unused | | EnvironmentSeg Environment segment | | PSP_OldStack far pointer to processes SS:SP ??? | | PSP_Nfiles maximum open files | | PSP_aofile ofile address | | Reserved3 Unused ??? | | PSP_int21 INT 21, far return | | Reserved4 Unused ??? | | PSP_FCB1ext FCB #1 extension | | PSP_FCB1 FCB #1 | | PSP_FCB2ext FCB #2 extension | | PSP_FCB2 FCB #2 | | PSP_DMA Command Tail | | | \*----------------------------------------------------------------*) PSPtype = record int20H : word; {00} TopOfMemory : word; {02} Reserved0 : byte; {04} PSP_DOS : array [0..4] of byte; {05} TerminationAddr, {0A} BreakExitAddr, {0E} CriticalErrorAddr : pointer; {12} ParentPSP_Seg : word; {16} OpenFiles : array [0..19] of byte; {18} EnvironmentSeg : word; {2C} PSP_OldStack : pointer; {2E} PSP_Nfiles : integer; {32} PSP_aofile : pointer; {34} Reserved3 : array [0..23] of byte; {38} PSP_int21 : array [0..1] of byte; {50} Reserved4 : array [0..1] of byte; {53} PSP_FCB1ext : array [0..6] of byte; {55} PSP_FCB1 : array [0..8] of byte; {5C} PSP_FCB2ext : array [0..6] of byte; {65} PSP_FCB2 : array [0..19] of byte; {6C} PSP_DMA : array [0..127] of byte {80} end; {$IFDEF VER40} (*--------------------------------------------------------------------*\ | NAME: GetEnv | | | | This routine is patterned after the UNIX operating system call | | which obtains the value of a specified environment variable. A | | process will inherit a copy of the parent's environment. Often, the | | environment variables are used to communicate between processes. | | Here are some examples of the usage of this function: | | | | s := GetEnv('PATH')) -- Sets "s" to the list of | | directories in which executable | | programs are to be found. | | writeln(GetEnv('PROMPT')) -- Prints the value of the DOS | | command interpreter prompt. | | s := GetEnv('INITFILE') -- Sets "s" to the value of the | | environment variable "FOO". | \*--------------------------------------------------------------------*) function GetEnv( envvar : string ) : string; (*--------------------------------------------------------------------*\ | NAME: EnvCount | | | | This function returns the number of environment strings set in | | the environment. | \*--------------------------------------------------------------------*) function EnvCount : integer; (*--------------------------------------------------------------------*\ | NAME: EnvStr | | | | This function returns the Index'th environment string. The | | string returned by this function is of the form 'VAR=VALUE.' If | | Index is beyond the last environment, then it will return a null | | string. | \*--------------------------------------------------------------------*) function EnvStr( Index : integer ) : string; {$ENDIF} (*--------------------------------------------------------------------*\ | NAME: GetProgramName | | | | This routine is used to obtain the full path name of the process | | with the given prefix segment. The following example shows you how | | to obtain the name of the program executing: | | | | s := GetProgramName( System.PrefixSeg ) | \*--------------------------------------------------------------------*) function GetProgramName( PrefixSeg : word ) : string; type (*----------------------------------------------------------------*\ | The following record type describes the contents of the Program | | Segment Prefix (PSP). | | | | Signature MCB id | | Owner PSP of process owning memory block | | Size Size in paragraphs of memory block | \*----------------------------------------------------------------*) MCB_entry = record Signature : char; Owner : word; Size : word; Unused : array [0..10] of byte end; MCB_pointer = ^MCB_entry; (*--------------------------------------------------------------------*\ | NAME: GetMCBhead | | | | This procedure is used for retrieving the address of the first | | MCB (Memory Control Block). This routine makes use of an undocu- | | mented DOS service ($52). | \*--------------------------------------------------------------------*) procedure GetMCBhead ( var MCBhead : MCB_pointer ); (*--------------------------------------------------------------------*\ | NAME: AdvanceMCBptr | | | | This procedure is used for advancing the pointer to an MCB so | | that it points to the next one in the chain. | \*--------------------------------------------------------------------*) procedure AdvanceMCBptr ( var MCBhead : MCB_pointer ); Implementation const WorkBuffer : string = ''; (*--------------------------------------------------------------------*\ | NAME: DateString | | | | This function will return the string representation of the | | information in the DateTime record type. | | | | EXTERNALS: | | type DateTime (from DOS unit) | | string[] MonthName (local to unit) | \*--------------------------------------------------------------------*) function DateString ( DT : DateTime ) : string; var y : string[4]; d,h,m,s : string[2]; begin str(DT.Day:2,d); str(DT.Year:4,y); str(DT.Hour:2,h); if h[1]=' ' then h[1] := '0'; str(DT.Min:2,m); if m[1]=' ' then m[1] := '0'; str(DT.Sec:2,s); if s[1]=' ' then s[1] := '0'; DateString := MonthName[DT.Month] + ' ' + d + ' ' + y + ' ' + h + ':' + m + ':' + s end; (* DateString *) (*--------------------------------------------------------------------*\ | NAME: GetSwitchChar | | | | This function will return the switch character (the character | | used to specify options) set in DOS. | \*--------------------------------------------------------------------*) function GetSwitchChar : char; var regs : registers; begin regs.AX := $3700; intr($21,regs); GetSwitchChar := chr(regs.DL) end; (* GetSwitchChar *) (*--------------------------------------------------------------------*\ | NAME: SetSwitchChar | | | | This function will set the switch character (the character | | used to specify options) set in DOS. | \*--------------------------------------------------------------------*) procedure SetSwitchChar ( c : char ); var regs : registers; begin regs.AX := $3701; regs.DL := ord(c); intr($21,regs) end; (* SetSwitchChar *) (*--------------------------------------------------------------------*\ | NAME: FixDirChars | | | | This function transforms the forward slash character ('/') into | | the backward slash character ('\') because version 5.0 of Turbo | | Pascal will do strange things if it finds the forward slash instead | | of the backward slash in a pathname. | \*--------------------------------------------------------------------*) function FixDirChars ( Original : string ) : string; var i : integer; begin WorkBuffer := Original; for i := 1 to length(Original) do if WorkBuffer[i] = ALT_DIR_SEPARATOR then WorkBuffer[i] := DIR_SEPARATOR; FixDirChars := WorkBuffer end; (* FixDirChars *) {$IFDEF VER40} (*--------------------------------------------------------------------*\ | NAME: FSplit | | | | This procedure splits a fully specified file name, and splits | | the filename into its components. | | | | EXTERNALS: | | const DIR_SEPARATOR, ALT_DIR_SEPARATOR (local to unit) | | function RCharPos (from My_Str unit) | \*--------------------------------------------------------------------*) procedure FSplit ( Path : PathStr; var Dir : DirStr; var Name : NameStr; var Ext : ExtStr ); var i,j : integer; begin i := RCharPos(DOS_SEP_CHARS,Path); if i=0 then begin Dir := ''; j := RCharPos(['.'],Path); if j=0 then begin Name := Path; Ext := '.' end else begin Name := copy(Path,1,j-1); Ext := copy(Path,j,length(Path)-j+1) end end else begin Dir := copy(Path,1,i); j := RCharPos(['.'],copy(Path,i+1,length(Path)-i)); if j=0 then begin Name := copy(Path,i+1,length(Path)-i); Ext := '.' end else begin Name := copy(Path,i+1,j-1); Ext := copy(Path,i+j,length(Path)-i) end end end; (* FSplit *) (*--------------------------------------------------------------------*\ | NAME: FExpand | | | | This function expands the file name to a fully qualified path | | file name. | | | | EXTERNALS: | | const DIR_SEPARATOR, ALT_DIR_SEPARATOR (local to unit) | | function RCharPos (from My_Str unit) | \*--------------------------------------------------------------------*) function FExpand ( Path : PathStr ) : PathStr; var i,j : integer; TmpStr : string; begin TmpStr := Path; (* strip off any drivespec and get pwd on drive *) if Pos(DSK_SEPARATOR,TmpStr) <> 2 then GetDir(0,WorkBuffer) else if not (Path[1] in Alphabet) then GetDir(0,WorkBuffer) else begin GetDir(ord(UpCase(TmpStr[1]))-ord('A')+1, WorkBuffer); TmpStr := copy(TmpStr,3,length(TmpStr)-2) end; (* strip trailing slash on pwd of selected drive *) if WorkBuffer[length(WorkBuffer)] in DIR_CHARS then dec(WorkBuffer[0]); (* handle reference to root *) if TmpStr[1] in DIR_CHARS then begin WorkBuffer[0] := #2; while TmpStr[1] in DIR_CHARS do TmpStr := copy(TmpStr,2,length(TmpStr)-1) end; i := CharPos(DIR_CHARS,TmpStr); while i<>0 do begin if copy(TmpStr,1,i-1)='.' then TmpStr := copy(TmpStr,3,length(TmpStr)-2) else if copy(TmpStr,1,i-1)='..' then begin TmpStr := copy(TmpStr,4,length(TmpStr)-2); j := RCharPos(DIR_CHARS,WorkBuffer); if j>0 then dec(WorkBuffer[0],length(WorkBuffer)-j+1) end else begin WorkBuffer := WorkBuffer + DIR_SEPARATOR + copy(TmpStr,1,i-1); TmpStr := copy(TmpStr,i+1,length(TmpStr)-i) end; i := CharPos(DIR_CHARS,TmpStr); end; FExpand := WorkBuffer + DIR_SEPARATOR + TmpStr end; (* FExpand *) {$ENDIF} (*--------------------------------------------------------------------*\ | NAME: PathName | | | | This function returns the path portion of the full path filename.| | This function interprets both '/' and '\' as directory separators. | | | | EXTERNALS: | | const DIR_SEPARATOR, ALT_DIR_SEPARATOR, DSK_SEPARATOR | | (local to unit) | | function rpos (from My_Str unit) | | function GetDir (from DOS unit) | \*--------------------------------------------------------------------*) function PathName( full : string ) : string; var i : integer; begin i := rpos(DIR_SEPARATOR,full); if i <> 0 then PathName := copy(full,1,i-1) else begin i := rpos(ALT_DIR_SEPARATOR,full); if i <> 0 then PathName := copy(full,1,i-1) else begin i := pos(DSK_SEPARATOR,full); if i = 2 then PathName := copy(full,1,2) else begin GetDir(0,full); if full[length(full)] = DIR_SEPARATOR then full[0] := chr(length(full)-1); PathName := full end end end end; (* PathName *) (*--------------------------------------------------------------------*\ | NAME: BaseName | | | | This function returns the base portion of a full path filename. | | This function interprets both '/' and '\' as directory separators. | | | | EXTERNALS: | | const DIR_SEPARATOR, ALT_DIR_SEPARATOR, DSK_SEPARATOR | | (local to unit) | | function rpos (from My_Str unit) | \*--------------------------------------------------------------------*) function BaseName( full : string ) : string; var i : integer; begin i := rpos(DIR_SEPARATOR,full); if i <> 0 then BaseName := copy(full,i+1,length(full)-i) else begin i := rpos(ALT_DIR_SEPARATOR,full); if i <> 0 then BaseName := copy(full,i+1,length(full)-1) else begin i := rpos(DSK_SEPARATOR,full); if i <> 0 then BaseName := copy(full,i+1,length(full)-i) else BaseName := full end end end; (* BaseName *) (*--------------------------------------------------------------------*\ | NAME: File_Exists | | | | This boolean function returns TRUE if the file exists. | \*--------------------------------------------------------------------*) function File_Exists ( s : string ) : boolean; var f : text; begin assign(f,s); {$i-} reset(f); {$i+} if ioresult <> 0 then File_Exists := FALSE else begin close(f); File_Exists := TRUE end end; (* File_Exists *) {$IFDEF VER40} const EnvironmentSeg : word = 0; (*--------------------------------------------------------------------*\ | Shared variables for GetEnv, EnvCount, and EnvStr. | \*--------------------------------------------------------------------*) const i : word = 0; Count : integer = 0; found : boolean = FALSE; (*--------------------------------------------------------------------*\ | NAME: GetEnv | | | | This routine is patterned after the UNIX operating system call | | which obtains the value of a specified environment variable. A | | process will inherit a copy of the parent's environment. Often, the | | environment variables are used to communicate between processes. | | | | EXTERNALS: | | word EnvironmentSeg (local to unit) | | integer i (local to unit) | | string WorkBuffer (local to unit) | | boolean found (local to unit) | \*--------------------------------------------------------------------*) function GetEnv( envvar : string ) : string; begin (* GetEnv *) i := 0; found := false; while not (found or (mem[EnvironmentSeg:i]=0)) do begin WorkBuffer := ''; while mem[EnvironmentSeg:i] <> ord('=') do begin WorkBuffer := WorkBuffer + chr(mem[EnvironmentSeg:i]); inc(i) end; inc(i); (* skip '=' *) found := WorkBuffer = envvar; WorkBuffer := ''; while mem[EnvironmentSeg:i] <> 0 do begin WorkBuffer := WorkBuffer + chr(mem[EnvironmentSeg:i]); inc(i) end; inc(i) (* skip '\0' *) end; if found then GetEnv := WorkBuffer else GetEnv := '' end; (* GetEnv *) (*--------------------------------------------------------------------*\ | NAME: EnvCount | | | | This function returns the number of environment strings set in | | the environment. | | | | EXTERNALS: | | word EnvironmentSeg (local to unit) | | integer i (local to unit) | | string WorkBuffer (local to unit) | | boolean found (local to unit) | \*--------------------------------------------------------------------*) function EnvCount : integer; begin i := 0; Count := 0; while (mem[EnvironmentSeg:i]<>0) do begin while mem[EnvironmentSeg:i] <> 0 do inc(i); inc(i); (* skip '\0' *) inc(Count) end; EnvCount := Count end; (* EnvCount *) (*--------------------------------------------------------------------*\ | NAME: EnvStr | | | | This function returns the Index'th environment string. The | | string returned by this function is of the form 'VAR=VALUE.' If | | Index is beyond the last environment, then it will return a null | | string. | | | | EXTERNALS: | | word EnvironmentSeg (local to unit) | | integer i (local to unit) | | integer Count (local to unit) | | string WorkBuffer (local to unit) | | boolean found (local to unit) | \*--------------------------------------------------------------------*) function EnvStr( Index : integer ) : string; begin i := 0; Count := 0; if (Count>=Index) or (mem[EnvironmentSeg:i]=0) then EnvStr := '' else begin repeat WorkBuffer := ''; inc(Count); while mem[EnvironmentSeg:i] <> 0 do begin WorkBuffer := WorkBuffer + chr(mem[EnvironmentSeg:i]); inc(i) end; inc(i) (* skip '\0' *) until ((Count = Index) or (mem[EnvironmentSeg:i]=0)); if Count = Index then EnvStr := WorkBuffer else EnvStr := '' end end; (* EnvStr *) {$ENDIF} (*--------------------------------------------------------------------*\ | NAME: GetProgramName | | | | This routine is used to obtain the full path name of the process | | with the given prefix segment. | | | | EXTERNALS: | | type PSPtype (local to unit) | \*--------------------------------------------------------------------*) function GetProgramName( PrefixSeg : word ) : string; const WorkBuffer : string[255] = ''; var i, EnvSeg : word; begin i := 0; EnvSeg := PSPtype(ptr(PrefixSeg,$0)^).EnvironmentSeg; while memw[EnvSeg:i] <> 0 do i := i + 1; i := i + 4; WorkBuffer := ''; while mem[EnvSeg:i] <> 0 do begin WorkBuffer := WorkBuffer + chr(mem[EnvSeg:i]); i := i + 1 end; GetProgramName := WorkBuffer end; (* GetProgramName *) (*--------------------------------------------------------------------*\ | NAME: GetMCBhead | | | | This procedure is used for retrieving the address of the first | | MCB (Memory Control Block). This routine makes use of an undocu- | | mented DOS service ($52). | | | | EXTERNALS: | | type MCB_pointer (local to unit) | | type registers (from DOS) | | procedure DecPtr (from PtrMath) | \*--------------------------------------------------------------------*) procedure GetMCBhead ( var MCBhead : MCB_pointer ); var regs : registers; TmpPtr : ^word; begin fillchar(regs,sizeof(regs),$0); regs.AH := $52; intr($21,regs); TmpPtr := ptr(regs.ES,regs.BX); DecPtr(pointer(TmpPtr),2); MCBhead := ptr(TmpPtr^,$0) end; (* GetMCBhead *) (*--------------------------------------------------------------------*\ | NAME: AdvanceMCBptr | | | | This procedure is used for advancing the pointer to an MCB so | | that it points to the next one in the chain. | | | | EXTERNALS: | | type MCB_pointer (local to unit) | \*--------------------------------------------------------------------*) procedure AdvanceMCBptr ( var MCBhead : MCB_pointer ); begin MCBhead := ptr(seg(MCBhead^)+MCBhead^.Size+1, ofs(MCBhead^)) end; (* AdvanceMCBptr *) (*====================================================================*\ || DOS_SVC unit initialization code || ||--------------------------------------------------------------------|| || EXTERNALS: || || function PrefixSeg || \*====================================================================*) var Junk : ExtStr; begin {$IFDEF VER40} FSplit(GetProgramName(PrefixSeg),ExecPath,ExecName,Junk); EnvironmentSeg := PSPtype(ptr(PrefixSeg,$0)^).EnvironmentSeg {$ELSE} FSplit(ParamStr(0),ExecPath,ExecName,Junk) {$ENDIF} End. ---- CUT HERE -------- CUT HERE -------- CUT HERE -------- CUT HERE ---- ---- CUT HERE -------- CUT HERE -------- CUT HERE -------- CUT HERE ---- unit MyMath; (*====================================================================*\ || MODULE NAME: MyMath || || DEPENDENCIES: System.TPU || || LAST MOD ON: 8904.05 || || PROGRAMMER: Naoto Kimura || || || || DESCRIPTION: This unit contains miscallaneous math routines. || || Among them are the 3-D coordinate manipulation || || routines. || \*====================================================================*) {$S+} {Stack checking on} {$R+} {Range checking on} {$D-} {Debug info off} {$I-} {I/O checking off} Interface function max( a, b : integer ) : integer; function min( a, b : integer ) : integer; function sgn( x : real ) : integer; function dmax( a, b : real ) : real; function dmin( a, b : real ) : real; function dsgn( d : real ) : real; function modulo( num, modulus :integer ) : integer; function rad2deg( r : real ) : real; function deg2rad( d : real ) : real; type coord3d = record x, y, z : real end; const X_AXIS : coord3d = ( x:1.0; y:0.0; z:0.0 ); Y_AXIS : coord3d = ( x:0.0; y:1.0; z:0.0 ); Z_AXIS : coord3d = ( x:0.0; y:0.0; z:1.0 ); ZERO_VEC : coord3d = ( x:0.0; y:0.0; z:0.0 ); function DistBetween ( var s1, s2 : coord3d ) : real; function VecLength (var a : coord3d) : real; procedure Normalize (var v : coord3d); procedure ScalarMult (var v : coord3d; n : real ); procedure ScalarDivs (var v : coord3d; n : real ); procedure VecDiff (var a, b, c : coord3d); procedure VecSum (var a, b, c : coord3d); procedure CrossProduct ( a, b : coord3d; var c : coord3d ); function DotProduct (var a,b : coord3d ) : real; function AngleBetween (var a,b : coord3d ) : real; procedure rot_Z ( var v : coord3d; t : real ); procedure rot_Y ( var v : coord3d; t : real ); procedure rot_X ( var v : coord3d; t : real ); Implementation function max( a, b : integer ) : integer; begin if a > b then max := a else max := b end; (* max *) function min( a, b : integer ) : integer; begin if a > b then min := b else min := a end; (* min *) function sgn( x : real ) : integer; begin if x=0 then sgn := 0 else if x>0 then sgn := 1 else sgn := -1 end; (* sgn *) function dmax( a, b : real ) : real; begin if a > b then dmax := a else dmax := b end; (* dmax *) function dmin( a, b : real ) : real; begin if a > b then dmin := b else dmin := a end; (* dmin *) function dsgn( d : real ) : real; begin if d=0.0 then dsgn := 0.0 else if d>0.0 then dsgn := 1.0 else dsgn := -1.0 end; (* dsgn *) function modulo( num, modulus :integer ) : integer; begin num := num mod modulus; if num < 0 then modulo := num + modulus else modulo := num end; (* modulo *) function rad2deg( r : real ) : real; begin rad2deg := r * 180.0 / PI end; (* rad2deg *) function deg2rad( d : real ) : real; begin deg2rad := PI * d / 180.0 end; (* deg2rad *) function DistBetween ( var s1, s2 : coord3d ) : real; begin DistBetween := sqrt( sqr( s1.x - s2.x ) + sqr( s1.y - s2.y ) + sqr( s1.z - s2.z ) ) end; (* DistBetween *) function VecLength (var a:coord3d) : real; begin VecLength := sqrt(sqr(a.x) + sqr(a.y) + sqr(a.z)) end; (* VecLength *) procedure Normalize (var v : coord3d); var l : real; begin l := VecLength(v); if abs(l) > 0.0 then l := 1 / l else l := 0; v.x := v.y * l; v.y := v.y * l; v.y := v.y * l end; (* Normalize *) procedure ScalarMult (var v : coord3d; n : real ); begin v.x := v.x * n; v.y := v.y * n; v.z := v.z * n end; (* ScalarMult *) procedure ScalarDivs (var v : coord3d; n : real ); begin if n <> 0 then begin v.x := v.x / n; v.y := v.y / n; v.z := v.z / n end end; (* ScalarMult *) procedure VecDiff (var a, b, c : coord3d); begin c.x := a.x - b.x; c.y := a.y - b.y; c.z := a.z - b.z end; (* VecDiff *) procedure VecSum (var a, b, c : coord3d); begin c.x := a.x + b.x; c.y := a.y + b.y; c.z := a.z + b.z end; (* VecSum *) procedure CrossProduct ( a, b : coord3d; var c : coord3d ); begin c.x := a.y*b.z-b.y*a.z; c.y := -a.x*b.z+b.x*a.z; c.z := a.x*b.y-a.y*b.x end; (* CrossProduct *) function DotProduct (var a,b : coord3d ) : real; begin DotProduct := a.x*b.x+a.y*b.y+a.z*b.z end; (* DotProduct *) function AngleBetween (var a,b : coord3d ) : real; var d : coord3d; p, ang, c, s : real; begin p := VecLength(a) * VecLength(b); if p = 0 then AngleBetween := 0 else begin c := DotProduct(a,b) / p; (* can be <0, >0, =0 *) CrossProduct(a,b,d); s := VecLength(d) / p; (* always >=0 *) if c=0 then (* Y-axis *) if s=0 then AngleBetween := 0 else AngleBetween := PI/2 else begin ang := arctan(s/c); if c<0 then ang:= ang + PI; (* quadrant 2 *) AngleBetween := ang end end end; (* AngleBetween *) procedure rot_Z ( var v : coord3d; t : real ); var old : coord3d; begin old := v; v.x := old.x * cos(t) - old.y * sin(t); v.y := old.y * cos(t) + old.x * sin(t) end; (* rot_Z *) procedure rot_Y ( var v : coord3d; t : real ); var old : coord3d; begin old := v; v.z := old.z * cos(t) - old.x * sin(t); v.x := old.x * cos(t) + old.z * sin(t) end; (* rot_Y *) procedure rot_X ( var v : coord3d; t : real ); var old : coord3d; begin old := v; v.y := old.y * cos(t) - old.z * sin(t); v.z := old.z * cos(t) + old.y * sin(t) end; (* rot_X *) End. ---- CUT HERE -------- CUT HERE -------- CUT HERE -------- CUT HERE ---- ---- CUT HERE -------- CUT HERE -------- CUT HERE -------- CUT HERE ---- unit MyStr; (*====================================================================*\ || MODULE NAME: MyStr || || DEPENDENCIES: System.TPU, MyMath.TPU || || LAST MOD ON: 8904.21 || || PROGRAMMER: Naoto Kimura || || || || DESCRIPTION: This is a library of string handling routines. || \*====================================================================*) {$R-} {Range checking off} {$S+} {Stack checking on} {$D-} {Debug info off} {$I-} {I/O checking off} {$N-} {No numeric coprocessor} Interface uses MyMath; type CharSet = set of char; const WhiteSpace : CharSet = [' ',#9,#10,#13]; UpperCase : CharSet = ['A'..'Z']; LowerCase : CharSet = ['a'..'z']; Alphabet : CharSet = ['A'..'Z','a'..'z']; Numeric : CharSet = ['0'..'9']; AlphaNum : CharSet = ['A'..'Z','a'..'z','0'..'9']; (*--------------------------------------------------------------------*\ | NAME: RPos | | | | This function returns the lastmost matching position of "needle" | | in "HayStack." | \*--------------------------------------------------------------------*) function RPos( needle, HayStack : string ) : byte; (*--------------------------------------------------------------------*\ | NAME: CharPos | | | | This routine gives the first position of specified characters in | | the string. | \*--------------------------------------------------------------------*) function CharPos( Srch : CharSet; HayStack : string ) : byte; (*--------------------------------------------------------------------*\ | NAME: RCharPos | | | | This routine gives the last position of specified characters in | | the string. | \*--------------------------------------------------------------------*) function RCharPos( Srch : CharSet; HayStack : string ) : byte; (*--------------------------------------------------------------------*\ | NAME: RightJustify | | | | This function returns a string that has the string "Original" | | right justified in a field of length "width" of the character "pad". | | If the string is longer than the field, the string will be truncated | | at the field width. | \*--------------------------------------------------------------------*) function RightJustify( Original : string; width : byte; pad : char ) : string; (*--------------------------------------------------------------------*\ | NAME: LeftJustify | | | | This function returns a string that has the string "Original" | | left justified in a field of length "width" of the character "pad". | | If the string is longer than the field, the string will be truncated | | at the field width. | \*--------------------------------------------------------------------*) function LeftJustify( Original : string; width : byte; pad : char ) : string; (*--------------------------------------------------------------------*\ | NAME: Center | | | | This function returns a string that has the string "Original" | | centered in a field of length "width" of the character "filler". If | | the string is longer than the field, the string will be truncated at | | the field width. | \*--------------------------------------------------------------------*) function Center( Original : string; width : byte; filler : char ) : string; (*--------------------------------------------------------------------*\ | NAME: Strip | | | | This function strips off the specified characters from Original. | | Leading characters to strip off are specified in LeadSet and | | trailing characters to strip off are specifed in TrailSet. | \*--------------------------------------------------------------------*) function Strip( Original : string; LeadSet, TrailSet : CharSet ) : string; (*--------------------------------------------------------------------*\ | NAME: SkipStr | | | | This routine is used to grab a copy of the string, past the | | location of the given pattern. | \*--------------------------------------------------------------------*) function SkipStr( Original, pattern : string ) : string; (*--------------------------------------------------------------------*\ | NAME: Reverse | | | | This function returns a copy of a string that is reversed. | \*--------------------------------------------------------------------*) function Reverse( Original : string ) : string; Implementation (*--------------------------------------------------------------------*\ | NAME: RPos | | | | This function returns the lastmost matching position of "needle" | | in "HayStack." | \*--------------------------------------------------------------------*) function RPos( needle, HayStack : string ) : byte; var i : byte; begin if length(HayStack) = 0 then RPos := 0 else if length(needle) = 0 then RPos := length(HayStack) else if length(needle) > length(HayStack) then RPos := 0 else begin for i := length(HayStack)-length(needle)+1 downto 1 do if copy(HayStack,i,length(needle)) = needle then begin RPos := i; exit end; RPos := 0 end end; (* RPos *) (*--------------------------------------------------------------------*\ | NAME: CharPos | | | | This routine gives the first position of specified characters in | | the string. | \*--------------------------------------------------------------------*) function CharPos( Srch : CharSet; HayStack : string ) : byte; var i : byte; begin if (HayStack = '') or (Srch = []) then CharPos := 0 else begin for i := 1 to length(HayStack) do if HayStack[i] in Srch then begin CharPos := i; exit end; CharPos := 0 end end; (* CharPos *) (*--------------------------------------------------------------------*\ | NAME: RCharPos | | | | This routine gives the last position of specified characters in | | the string. | \*--------------------------------------------------------------------*) function RCharPos( Srch : CharSet; HayStack : string ) : byte; var i : byte; begin if (HayStack = '') or (Srch = []) then RCharPos := 0 else begin for i := length(HayStack) downto 1 do if HayStack[i] in Srch then begin RCharPos := i; exit end; RCharPos := 0 end end; (* RCharPos *) (*--------------------------------------------------------------------*\ | NAME: RightJustify | | | | This function returns a string that has the string "Original" | | right justified in a field of length "width" of the character "pad". | | If the string is longer than the field, the string will be truncated | | at the field width. | \*--------------------------------------------------------------------*) function RightJustify( Original : string; width : byte; pad : char ) : string; var result : string; begin fillchar(result[1],width,pad); result[0] := char(width); move(Original[1],result[max(width-length(Original)+1,1)], min(length(Original),width)); RightJustify := result end; (* RightJustify *) (*--------------------------------------------------------------------*\ | NAME: LeftJustify | | | | This function returns a string that has the string "Original" | | left justified in a field of length "width" of the character "pad". | | If the string is longer than the field, the string will be truncated | | at the field width. | \*--------------------------------------------------------------------*) function LeftJustify( Original : string; width : byte; pad : char ) : string; var result : string; begin fillchar(result[1],width,pad); result[0] := char(width); move(Original[1],result[min(width-length(Original)+1,1)], min(length(Original),width)); LeftJustify := result end; (* LeftJustify *) (*--------------------------------------------------------------------*\ | NAME: Center | | | | This function returns a string that has the string "s" centered | | in a field of length "len" of the character "filler". If the string | | is longer than the field, the string will be truncated at the field | | width. | \*--------------------------------------------------------------------*) function Center( Original : string; width : byte; filler : char ) : string; var off : byte; result : string; begin result[0] := char(width); fillchar(result[1],width,filler); off := max(((width-length(Original)) div 2)+1,1); move(Original[1],result[off],min(length(Original),width)); Center := result end; (* Center *) (*--------------------------------------------------------------------*\ | NAME: Strip | | | | This function strips off the specified characters from Original. | | Leading characters to strip off are specified in LeadSet and | | trailing characters to strip off are specifed in TrailSet. | \*--------------------------------------------------------------------*) function Strip( Original : string; LeadSet, TrailSet : CharSet ) : string; var Left, Right : byte; stop : boolean; begin Left := 1; Right := length(Original); if Left>Right then stop := FALSE else stop := not (Original[Left] in LeadSet) and not (Original[Right] in TrailSet); while not (stop or (Right<Left)) do begin stop := TRUE; if Original[Left] in LeadSet then begin inc(Left); stop := FALSE end; if Original[Right] in TrailSet then begin dec(Right); stop := FALSE end end; if stop then Strip := copy(Original,Left,Right-Left+1) else Strip := '' end; (* Strip *) (*--------------------------------------------------------------------*\ | NAME: SkipStr | | | | This routine is used to grab a copy of the string, past the | | location of the given pattern. | \*--------------------------------------------------------------------*) function SkipStr( original, pattern : string ) : string; begin SkipStr := copy(original, pos(pattern,original)+length(pattern), length(original)) end; (* SkipStr *) (*--------------------------------------------------------------------*\ | NAME: Reverse | | | | This function returns a copy of a string that is reversed. | \*--------------------------------------------------------------------*) function Reverse( Original : string ) : string; var i,j : byte; result : string; begin result[0] := Original[0]; j := length(Original); for i := 1 to length(Original) do begin result[i] := Original[j]; dec(j) end; Reverse := result end; (* Reverse *) end. ---- CUT HERE -------- CUT HERE -------- CUT HERE -------- CUT HERE ---- //-n-\\ Naoto Kimura _____---=======---_____ (abcscnuk@csuna.csun.edu) ====____\ /.. ..\ /____==== // ---\__O__/--- \\ Enterprise... Surrender or we'll \_\ /_/ send back your *&^$% tribbles !!