/**********************************************************************/ /**********************************************************************/ /* 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;