/**********************************************************************/
/**********************************************************************/
/* THE FILES CONTAINED HEREIN ARE PROVIDED BY SAS INSTITUTE INC. */
/* "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, */
/* INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF */
/* MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. RECIPIENTS */
/* ACKNOWLEDGE AND AGREE THAT SAS INSTITUTE SHALL NOT BE LIABLE */
/* WHATSOEVER FOR ANY DAMAGES ARISING OUT OF THEIR USE OF THIS */
/* MATERIAL. IN ADDITION, SAS INSTITUTE WILL PROVIDE NO SUPPORT FOR */
/* THE MATERIALS CONTAINED HEREIN. */
/**********************************************************************/
/**********************************************************************/
/* CGMSPLIT.SAS--Program to split a CGM file with multiple */
/* pictures into multiple files */
/* */
/* The authors may be reached at the following addresses: */
/* */
/* Dr. Wolfgang Kössler */
/* Humboldt-Universität zu Berlin */
/* Institut für Informatik */
/* Lindenstr. 54a */
/* 10099 Berlin */
/* Koessler@informatik.hu-berlin.de */
/* */
/* Wolf F. Lesener */
/* Humboldt-Universität zu Berlin */
/* Rechenzentrum */
/* Unter den Linden 6 */
/* 10099 Berlin */
/* wflesener@rz.hu-berlin.de */
%let urcgm=cgm-file-name; /* CGM input file for */
/* splitting. */
filename urcgm "&urcgm";
options pageno=1 nocenter noxwait;
/* Step 1: process the CGM input filename, and determine record length of */
/* CGM file. Then create a directory with the same name as the CGM */
/* file. This directory will contain the individual pictures. */
data _null_;
call symput('dir',reverse(scan(reverse(trim(symget('urcgm'))),2,'.')));
infile urcgm recfm=n length=lrecl;
input h $char1.;
call symput('lrecl',left(put(lrecl,5.)));
stop;
run;
%put DIR=&dir LRECL=&lrecl; /* Echo file name and lrecl */
dm 'x "mkdir &dir";'; /* Create directory with same name as CGM file */
/* The following statement is optional to delete */
/* all files PICT*.CGM from the directory */
dm 'x "del &dir\pict*.cgm > nul";';
/* Step2 : Store contents of metafile in a SAS data set (HEX) and store */
/* begin and end pointer for each header and picture in another */
/* SAS data set (LOC). LOC contains one record for each picture in */
/* the file. Note that the structure of the CGM file will depend */
/* on whether it was created by a single SAS/GRAPH procedure or by */
/* multiple procedures using GOPTIONS GSFMODE=APPEND. */
data hex (keep=hex1-hex&lrecl)
loc (keep=head1 head2 pict1 pict2);
array hex(*) $ 1 hex1-hex&lrecl; /* Contents of CGM record */
/* The following arrays contain the hex codes that denote the beginning and */
/* end of various components of the metafile */
array bom(*) $ 1 bom1-bom2 ('00'x '3c'x); /* codes for start of metafile */
array bop(*) $ 1 bop1-bop2 ('00'x '7F'x); /* codes for start of picture */
array eop(*) $ 1 eop1-eop3 ('00'x 'A0'x '00'x); /* codes for end of picture */
array eom(*) $ 1 eom1-eom2 ('7F'x '40'x); /* codes for end of metafile */
retain head1 head2 pict1 pict2;
retain status (0);
retain k (1);
length c $1;
infile urcgm recfm=n eof=eof;
do i=1 to &lrecl;
input c $char1.; /* read next byte of metafile */
hex(i)=c; /* store this byte in an array */
nc+1;
if c='20'x then continue; /* skip blanks */
select (status); /* STATUS variable indicates what we */
/* are looking for next */
when (0) /* look for code indicating beginning */
do; /* of metafile */
if c=bom(k) then k+1;
if k=2 and '30'x<=c<='3F'x then k+1;
else k=(c=bom1)+1;
if k=3 then do; /* metafile header has been found */
status=1;
k=1;
head1=nc-1; /* location of beginning of header */
end;
end;
when (1) /* look for code indicating beginning */
do; /* of picture */
if c=bop(k) then k+1;
else k=(c=bop1)+1;
if k=3 then do; /* beginning of picture has been found */
status=2;
k=1;
head2=nc-2; /* location of end of header */
pict1=nc-1; /* location of beginning of picture */
end;
end;
when (2) /* look for code indicating end of */
do; /* picture */
if c=eop(k) then k+1;
else k=(c=eop1)+1;
if k=4 then do; /* end of picture has been found */
status=3;
k=1;
end;
end;
when (3) /* now check to see if we are at end or if there is another picture */
/* If the next character is a '7F'x, then another picture follows */
/* If the next character is a '40'x, we have encountered an */
/* "end of metafile" flag. */
do;
if c=eom1 then do; /* If we find another picture, prepare */
status=2; /* to extract it. */
pict2=nc-2; /* Location of end of previous picture */
output loc; /* Output info about previous picture to */
/* LOC */
pict1=nc-1; /* Location of beginning of next picture */
end;
if c=eom2 then do; /* If we hit end of metafile flag ... */
status=0; /* Prepare to read next metafile header */
pict2=nc-2; /* Location of end of previous picture */
output loc; /* Output info about previous picture to */
/* LOC */
end;
if status=3 then do; /* If we are not at end of picture, read */
/* next character */
status=2;
k=(c=eop1)+1;
end;
end;
end;
end;
eof: output hex; /* At end of processing metafile record, output whole record to HEX */
run;
/* Step 3: print the beginning and end location of each header and picture in */
/* the physical file, and create a macro variable N containing the */
/* number of pictures. */
title "&dir";
footnote;
proc print data=loc;
data _null_;
set loc nobs=n;
call symput('n',left(put(n,5.)));
stop;
run;
%put N=&n (number of pictures containing in urcgm);
/* Step 4: create a single CGM output file per picture by direct access to */
/* WORK.LOC (beginning and end locations of the actual picture) and */
/* WORK.HEX (CGM input file stored as a SAS data set) */
%macro pict(n);
%local i;
%do i=1 %to &n; /* go through this loop once for each picture */
filename cgm "&dir\pict&i..cgm"; /* Create a separate file for each picture */
/* Files will be named PICT1.CGM, PICT2.CGM */
/* and so on. In this step, we move along */
/* the input buffer (array HEX) and writing */
/* the information to an output buffer */
/* (array PIC), resetting the start point */
/* with each new header */
data _null_;
array hex(*) $ 1 hex1-hex&lrecl; /* input record */
array pic(*) $ 1 pic1-pic&lrecl; /* output record */
array eof(*) $ 1 eof1-eof2 ('00'x '40'x);
retain k (0); /* position of last character stored in the */
/* output record */
file cgm recfm=n; /* Open CGM output file */
p=&i; /* get picture number */
set loc point=p; /* Read observation from LOC that */
/* corresponds to picture number */
/* Works similar assigning values to */
/* beginning (HEAD1) and end (HEAD2) of */
/* header and beginning (PICT1) and */
/* end (PICT2) of picture body */
h1=ceil(head1/&lrecl); /* First observation of HEX containing a */
/* part of the header */
h2=ceil(head2/&lrecl); /* Last observation of HEX containing a */
/* part of the header */
c1=head1-(h1-1)*&lrecl; /* First character of the header in the */
/* observation that corresponds to H1 */
c2=head2-(h2-1)*&lrecl; /* Last character of the header in the */
/* observation that corresponds to H2 */
do i=h1 to h2; /* Process each record containing a part of */
/* the header */
set hex point=i; /* Read observation of HEX */
if i=h1 then j1=c1; /* J1 contains the starting point for */
/* processing the actual header record */
/* byte by byte */
/* If the first header record will be */
/* processed the starting point is C1 */
else j1=1; /* For all subsequent header records the */
/* starting point is constant 1 */
if i=h2 then j2=c2; /* J2 contains the end point for processing */
/* the actual header record byte by byte */
/* If the last header record will be */
/* processed the end point is C2 */
else j2=&lrecl; /* For all previous header records the end */
/* point is constant LRECL */
do j=j1 to j2; /* Process each byte of header record */
if k=&lrecl then do; /* If output record PIC is filled, */
k=0; /* reset next output record position and */
/* write header data in chunks of bytes */
/* equal to lrecl of input file */
put (pic1-pic&lrecl) ($char1.);
end;
k+1; /* Copy the actual header byte to the next */
pic(k)=hex(j); /* output record byte */
end;
end;
/* Begin processing of the picture body */
p1=ceil(pict1/&lrecl); /* First observation of HEX containing a */
/* part of the picture body */
p2=ceil(pict2/&lrecl); /* Last observation of HEX containing a */
/* part of the picture body */
c1=pict1-(p1-1)*&lrecl; /* First character of the picture body in */
/* the observation that corresponds to P1 */
c2=pict2-(p2-1)*&lrecl; /* Last character of the picture body in */
/* the observation that corresponds to P2 */
do i=p1 to p2; /* Process each record containing a part of */
/* the picture body */
set hex point=i; /* Read observation of HEX */
if i=p1 then j1=c1; /* J1 contains the starting point for */
/* processing the actual picture body */
/* record byte by byte */
/* If the first picture body record will be */
/* processed the starting point is C1 */
else j1=1; /* For all subsequent picture body records */
/* the starting point is constant 1 */
if i=p2 then j2=c2; /* J2 contains the end point for processing */
/* the actual picture body record */
/* If the last picture body record will be */
/* processed the end point is C2 */
else j2=&lrecl; /* For all previous picture body records */
/* the end point is constant LRECL */
do j=j1 to j2; /* Process each byte of picture body record */
if k=&lrecl then do; /* If output record PIC is filled, */
k=0; /* reset next output record position and */
/* write picture body data in chunks of */
/* bytes equal to lrecl of input file */
put (pic1-pic&lrecl) ($char1.);
end;
k+1; /* Copy the actual picture body byte to the */
pic(k)=hex(j); /* next output record byte */
end;
end;
/* close the output metafile */
do j=1 to 2; /* Process each eof-byte '00'x and '40'x */
if k=&lrecl then do; /* If output record PIC is filled, */
k=0; /* reset next output record position and */
/* write picture body data in chunks of */
/* bytes equal to lrecl of input file */
put (pic1-pic&lrecl) ($char1.);
end;
k+1; /* Copy the actual end-of-file-byte to the */
pic(k)=eof(j); /* next output record byte */
end;
do j=k+1 to &lrecl; /* Clean the remaining characters of the */
pic(j)='20'x; /* last output record with blanks */
end;
/* Write the last record of output CGM */
put (pic1-pic&lrecl) ($char1.);
stop;
run;
%end;
%mend pict;
%pict(&n)
/* clear used filerefs */
filename urcgm clear;
filename cgm clear;