*process source nest gonumber flag(w) opt(time); *process interrupt; *Process MARGINS( 2, 100 ), linecount(55); *Process LANGLVL( SAA2 os2 ) NOT('ª^') OR('|'); *Process LIMITS(EXTNAME(31)); *Process INCLUDE(EXT('CPY')); *Process macro; utillib:package exports(*); %noprint; %INCLUDE OS2PLI; %INCL_DOS = 'Y'; %INCLUDE OS2; %print; dcl (length, addr) builtin; %include upcase; %null:procedure returns(char); return('null()'); %end null; %activate null scan; /* file system related DOS functions */ GetDefaultDrive:procedure returns(char(1)); dcl ulDriveNum init(0) Ulong; dcl ulDriveMap init(0) Ulong; dcl rc APIRET; rc = DosQueryCurrentDisk(ulDriveNum, ulDriveMap); call pliretc(rc); return(DriveLetter(ulDriveNum)); end GetDefaultDrive; GetDefaultPath:procedure(DiskName) returns(char(256) varying); dcl DiskName char(1); dcl DiskNum init((DriveNumber(DiskName))) ULONG; dcl DirName char(256) varyingz init(''); dcl DirX char(256) varying; dcl PathLength init(255) ULONG; dcl rc APIRET; rc = DosQueryCurrentDir(DiskNum, addr(DirName), PathLength); call pliretc(rc); DirX = DirName; if length(DirX) > 0 then DirX = '\' || DirX; return(DirX); end GetDefaultPath; SetDefaultDrive:procedure(DrvLetter) returns(optional bit(1)); dcl DrvLetter char(1); dcl DrvNum init((DriveNumber(DrvLetter))) ULONG; dcl rc APIRET; rc = DosSetDefaultDisk(DrvNum); call pliretc(rc); if rc = 0 then return('1'b); else return('0'b); end SetDefaultDrive; SetDefaultPath:procedure(PathName) returns(optional bit(1)); dcl PathName char(*) varying; dcl Path char(256) varyingz init(PathName); dcl rc APIRET; rc = DosSetCurrentDir(addr(Path)); call pliretc(rc); if rc = 0 then return('1'b); else return('0'b); end SetDefaultPath; /* file system related string functions */ HasExtension:procedure(Name, DotPos) returns(optional bit(1)); dcl name char(*) varying, (DotPos, i) fixed bin(15); DotPos = 0; i = searchr(name,'.\:'); if i = 0 then return('0'b); /* no extension */ select(substr(name,i,1)); when('\',':') return('0'b); /* no extension */ otherwise do; DotPos = i; Return('1'b); end; end; end HasExtension; DefaultExtension:procedure(name, ext) returns(char(256) varying); dcl (name, ext) char(*) varying, DotPos fixed bin(15); if HasExtension(name, DotPos) then return(name); else if length(name) = 0 then return(''); else return(name || '.' || ext); end DefaultExtension; ForceExtension:procedure(name, ext) returns(char(256) varying); dcl (name, ext) char(*) varying, DotPos fixed bin(15); if HasExtension(name, DotPos) then return(substr(name,1,DotPos) || ext); else if length(name) = 0 then return(''); else return(name || '.' || ext); end ForceExtension; JustExtension:procedure(name) returns(char(256) varying); dcl name char(*) varying, DotPos fixed bin(15); if HasExtension(name, DotPos) then return(substr(name,DotPos+1)); else return(''); end JustExtension; JustFileName:procedure(name) returns(char(256) varying); dcl name char(*) varying, i fixed bin(15) init((searchr(name,'\:'))); if i = 0 then return(name); else return(substr(name,i+1)); end JustFileName; JustName:procedure(name) returns(char(256) varying); dcl name char(*) varying, filename char(256) varying init((JustFileName(name))), DotPos fixed bin(15) init((searchr(filename,'.'))); select(DotPos); when(0) return(filename); otherwise return(substr(filename,1,DotPos-1)); end; end JustName; JustPathName:procedure(name) returns(char(256) varying); dcl name char(*) varying, (i, j) fixed bin(15); if length(name) = 0 then return(''); /* no name */ i = searchr(name,':\'); if i = 0 then /* has no drive or directory name */ return(''); if i = 1 then do; if substr(name,i,1) = '\' then return('\'); else return(''); /* invalid path */ end; if substr(name,i,1) = '\' then do; if substr(name,i,1) = ':' then /* root dir */ return(substr(name,1,i)); else return(substr(name,1,i-1)); end; return(substr(name,i,1)); end JustPathName; JustDriveLetter:procedure(name) returns(char(1)); dcl name char(*) varying, c char(1), i fixed bin(15) init((search(name,':'))); if i ^= 2 then /* no valid drive letter - return default */ return(' '); c = UpCase(substr(name,1,1)); if c < 'A' | c > 'Z' then return(' '); else return(c); end JustDriveLetter; DriveNumber:procedure(Drive) returns(fixed bin(15)); dcl drive char(1); return(search(UpcaseTRT, Upcase(Drive))); end DriveNumber; DriveLetter:procedure(DriveNum) returns(char(1)); dcl DriveNum fixed bin(15); if DriveNum < 1 | DriveNum > 26 then return(' '); else return(substr(UpcaseTRT, DriveNum, 1)); end DriveLetter; AddBackSlash:procedure(DirName) returns(char(256) varying); dcl DirName char(*) varying, i fixed bin(15) init((searchr(DirName,'\'))); if length(DirName) = 0 then return(''); select(substr(DirName,1,1)); when('\',':') return(DirName); otherwise return(DirName || '\'); end; end AddBackSlash; CLP_Definition:procedure; /* Command Line Parser */ /*========================================================== Command line parser. Command line syntax: :: =pgm { | | } 0-n times ::= {any characters except a blank} ::= {any characters except a } ::= [' | "] NOTE: same quote char must be used at each end of the quoted string ::= [ / | -]{:}{|} NOTE: '/' will mark the end of any non-quoted text. - is treated just like any other chatacrer. Therefore, these two strings will parse in different ways: /1/2/3 will parse to three switches: '1','2' and '3', all with no aruments; -1-2-3 will parse to one switch '1', with the argument '-2-3'. file-n.dat parses as one positional parameter: 'file-n.dat'; file/n.dat parse to the positional parameter 'file', and a switch,'n', with the argument '.dat'. Example: copy file.from /trb "file to" -f -h:'heading text' ===========================================================*/ dcl txt char(*) varying, sw char(1), h pointer, n fixed bin(15), text_length_def fixed bin(15), switch_name_def char(1), text_def char(256) varying, respect_case bit(1); dcl 1 CLP_object based, ( 2 head, 2 tail ) pointer init(null), ( 2 cnt, 2 posit, 2 swcount ) fixed bin(15) init(0), 2 respect_sw_case bit(1); dcl p pointer, 1 CLP_entry based(p), 2 prior pointer init(null), 2 next pointer init(null), 2 positional fixed bin(15), 2 switch_name char(1) init(switch_name_def), 2 text_length fixed bin(15), 2 text char(text_length_def refer(text_length)) init(text_def); CLP_Init: Entry(h, respect_case); allocate CLP_object set(h); h -> respect_sw_case = respect_case; return; CLP_Process: entry(h, txt) returns(optional fixed bin(15)); if length(txt) > 0 then call process; return(h -> cnt); CLP_ParameterCount: entry(h) returns(fixed bin(15)); return(h -> cnt); CLP_PositionalCount: entry(h) returns(fixed bin(15)); return(h->posit); CLP_SwitchCount: entry(h) returns(fixed bin(15)); return(h->swcount); CLP_GetPositional: entry(h, n, txt) returns(optional bit(1)); return(return_positional()); CLP_GetSwitch: entry(h, n, sw, txt) returns(optional bit(1)); return(return_switch()); CLP_GetSwitchByName: entry(h, sw, txt) returns(bit(1)); return(return_switch_by_name()); return; CLP_Done: entry(h); call done; return; CLP_Dump: Entry(h, txt); call dump; return; process:procedure; dcl i fixed bin(15) init(1), j fixed bin(15); do while(i < length(txt)); /* goto first non-blank */ do i=i to length(txt) by 1 while(substr(txt,i,1) = ' '); end; if substr(txt,i,1) = ' ' then /* only blanks left */ return; /* so all done */ switch_name_def = ''; text_def = ''; select(substr(txt,i,1)); when('"') call get_string('"'); when("'") call get_string("'"); when('/','-') call get_switch; otherwise call get_string(' /'); end; if switch_name_def = ' ' & text_def = '' then /* must be no more data */ return; if switch_name_def = ' ' then /* inc positional counter */ call add_entry(h -> posit); else call add_switch; end; add_switch:procedure; dcl p pointer; /* first see if the switch exists, if so - delete the old entry first */ lookup: do p = h -> head repeat p -> next while( p ^= null); if p -> switch_name = switch_name_def then do; call delete_entry(p); leave lookup; end; end lookup; /* add the switch entry */ call add_entry(h -> swcount); end add_switch; delete_entry:procedure(p); dcl p pointer; select(p); when(h->head) if p -> next = null then h -> head = null; else do; h -> head = p -> next; h -> head -> prior = null; end; when(h->tail) do; h -> tail = p -> prior; h -> tail -> next = null; end; otherwise do; p -> prior -> next = p -> next; p -> next -> prior = p -> prior; end; end; free p -> CLP_entry; end delete_entry; add_entry:procedure(pos); dcl pos fixed bin(15); text_length_def = length(text_def); allocate CLP_entry; h -> cnt += 1; pos += 1; p -> positional = pos; if h -> head = null then h -> head = p; else do; p -> prior = h -> tail; h -> tail -> next = p; end; h -> tail = p; end add_entry; get_string:procedure(term); dcl term char(*), initial_term char(1) init((substr(txt,i,1))); if substr(term,1,1) ^= ' ' then i += 1; if i > length(txt) then return; j = search(txt, term, i); if j = 0 then /* get to end-of-line */ do; text_def = substr(txt,i); i = length(txt) + 1; end; else do; text_def = substr(txt,i, j-i); select(initial_term); when('"',"'") i = j + 1; otherwise i = j; end; end; end get_string; get_switch:procedure; i += 1; if i > length(txt) then return; /* nothing to get */ switch_name_def = substr(txt,i,1); if ^ h -> respect_sw_case then switch_name_def = upcase(switch_name_def); /* process any switch arguments */ i += 1; if i > length(txt) then /* no arguments */ return; if substr(txt,i,1) = ' ' | substr(txt,i,1) = '/' then return; /* no arguments */ if substr(txt,i,1) = ':' then i += 1; /* skip the ':' */ if i > length(txt) then return; /* no arguments */ /* get switch argument */ select(substr(txt,i,1)); when('"') call get_string('"'); when("'") call get_string("'"); otherwise call get_string(' /'); end; end get_switch; end process; return_positional:procedure returns(bit(1)); do p = h -> head repeat p -> next while( p ^= null); if p -> switch_name = ' ' & p -> positional = n then do; txt = p -> text; return('1'b); end; end; txt = ''; return('0'b); end return_positional; return_switch: procedure returns(bit(1)); do p = h -> head repeat p -> next while( p ^= null); if p -> switch_name ^= ' ' & p -> positional = n then do; sw = p -> switch_name; txt = p -> text; return('1'b); end; end; switch_name, txt = ''; return('0'b); end return_switch; return_switch_by_name: procedure returns(bit(1)); do p = h -> head repeat p -> next while( p ^= null); if h -> respect_sw_case then do; if p -> switch_name = sw then do; txt = p -> text; return('1'b); end; end; else do; if p -> switch_name = upcase(sw) then do; txt = p -> text; return('1'b); end; end; end; txt = ''; return('0'b); end return_switch_by_name; dump:procedure; dcl i dec(2) init(1); put skip(2) edit('CLP_Object Dump: ', txt)(a,a(length(txt))); put skip edit('count= ', h-> cnt)(col(5),a,f(5)); put skip edit('positionals=', h -> posit)(col(5),a,f(5)); put skip edit('switches= ', h -> swcount)(col(5),a,f(5)); if h -> cnt > 0 then do p = h -> head repeat p -> next while( p ^= null); put skip edit(i, p -> positional, p -> switch_name, p -> text) ((2)(f(2),x(1)),a,x(1),a(length(p -> text))); i += 1; end; put skip edit('---------------')(a); end dump; done:procedure; dcl t pointer; if h -> cnt > 0 then do p = h -> head repeat t while( p ^= null); t = p -> next; free p -> CLP_entry; end; free h -> CLP_object; end done; end CLP_Definition; end utillib;