PC Online 1999 November/PCONLINE_11_99.ISO/filesbbs/OS2/APCHSSL2.ZIP/OS2HTTPD/public/cgi-bin/gif_text.cmd

Text File | 1998-12-12 | 76.9 KB | 2,423 lines

/* 04 dec 1997.   SRE-http utility and generic CGI-BIN script:
GIF_TEXT: create a gif file containing a message, using an
          "alphabyte" collection of character files.

This program will work as a:
 1)"native" SRE-http add-on,
 2) as a generic CGI-BIN script
 3) a stand/alone program
...it will automatically detect how it's being called.

NOTE: You MUST set the GIF_DIR_ROOT parameter below (other parameters are
      optional).

************************************************************************/

signal on error name wow1 ; signal on syntax name wow1 ;


/******************************************************
  ***********BEGIN USER CHANGABLE PARAMETERS ******************************
  ***********BEGIN USER CHANGABLE PARAMETERS ******************************
  ***********BEGIN USER CHANGABLE PARAMETERS ******************************/

/*-                   --------------------
                    User changeable parameters

The user changeable parameters are:

GIF_DIR_ROOT : The "root" directory of the "alphabytes".

         !!!!  YOU MUST SET GIF_DIR_ROOT WHEN YOU INSTALL GIF_TEXT  !!!!!
                All the other parameters can be left unchanged with
                minimal deteriment, but GIF_TEXT will not work
                if GIF_DIR_ROOT is not properly set.

SEND_PIECES: Try to send early versions of the image, as they become available
DEFAULT_FONT : The default "alphabyte font" (actually, it's directory)
FONT_NAME : Name (prefix) used to match characters to .GIF files
FONT_INDEX : Index file with "alphabyte specific" configuration information
CACHE_SIZE : The maximum number of images to "cache"
CACHE_DURATION : Maximum duration of cached images
HEIGHT : Default height of the created image
WIDTH : Default width of the created image
X_FRAME: Width of frame, in pixels (left and right)
Y_FRAME: Height of frame, in pixels (top and bottom)
TIME_FMT : Default format to use when display current time
DATE_FMT : Default format to use when displaying current date
DEF_BACKCOLOR= Default backcolor
DEF_TEXTCOLOR= Default textcolor (used when no character .GIF file is available)
DEF_TRANSPARENT = Default transparent color index
DEF_TEXTSIZE = Default size of default text characters

*  You MUST set the GIF_DIR_ROOT parameter
*  The SEND_PIECES parameter is useful if you are using SRE-http, and
    large/complicated images are likely
    to be created (which may require the client to wait a minute or more).
*  You should, but do not need to, set the TIME_FMT, DATE_FMT, and FONT_DIR
   parameters.
*  You should probably set HEIGHT=0 and WIDTH=0.
*  You should probably set FONT_NAME=' ' and FONT_INDEX=' '
*  The DEF_BACKCOLOR, and DEF_TEXTCOLOR are usually
   overridden by "alphabyte" specific values,so you probably
   don't need to worry about them.
*  The DEF_TEXTSIZE is  rarely used (only if there are NO matching characters)!
*  The DEF_TRANSPARENT should almost always equal 0

*  CACHE_SIZE=100 and CACHE_DURATION=1 are reasonable values; but if you
   want to avoid clutter, set CACHE_SIZE=0 (in which case, the
   CACHE option is ignored)


                                -----------------
-*/
/*  !!!! You MUST set the GIF_DIR_ROOT parameter !!!! */
/* The "base directory" of the alphabytes (the collection of character gifs) */
/* if no drive is specified, the default drive (i.e.; the goserve working
directory) will be used */
gif_dir_root='\os2httpd\alphabyt'

/* Attempt to send "pieces" (actually, less detailed versions) of the image as it becomes
   available (only works with browsers that recognize connection:keep-alive).
   1=yes, 0=no
   Send_pieces will ONLY work if GIF_TEXT is called as an SRE-http addon*/
send_pieces=1


/* Default font directory (relative to gif_dir_root) */
DEFAULT_FONT='enviro'

/* default font name.If ' ', use "font_dir own name". This should NOT
   include directory information */
font_name=' '

/* default "index file" (in font_dir) -- contains alphabyte specific
   configuration information. If ' ', usein font_name.ind.
   This should NOT contain subdirectory information. */
font_index=' '

/* the maximum number of images to cache. 0 means "disable caching of images"*/
cache_size=100

/* the maximum lifespan of an image cache file. 0 means "disable caching".
   (measured in days, no fractions allowed). */
cache_duration=1

/* default height in pixels (0= as big as needed) */
height=0
/* default width in pixels (0=as big as needed) */
width=0

/* default size of frame, left and right */
x_frame=0

/* default size of frame, top and bottom */
y_frame=0

/* time format (using REXX TIME('x') syntax); eg; N= 15:32:01*/
time_fmt='N'
/*date format (using REXX DATE('x') syntax ); eg; N=16 Jun 1997 */
date_fmt='N'

/* Set the default RGB intensities for the background (color table #0)
   Use a 6-hex-character (00 to ff); with 000000=black and ffffff=white.
   This may be overridden by the font-index file, or by an option  */
def_backcolor=b0b0b0


/* set values to use for characters when a .gif file can not be found
   This may be overridden by the font-index file, or by an option */
def_textcolor=ffffff

/* size of text, in pixel, if NO gifs found */
def_text_size =15

/* set the "transparent color index" -- use a value between 0 and 255.
  If you do NOT want a transparent color index, use -1. */
def_transparent=0

/* verbose level (only used if called as cgi-bin script:
  0=none, 1=minimal, 2=more
 If called as SRE-http addon, then SRE-http's VERBOSE variable is used */
def_verbose=2

/* background scaling: 1 for yes, 0 for use tiles */
back_scale=0


/********** END of USER CHANGABLE PARAMETERS *********/
/********** END of USER CHANGABLE PARAMETERS *********/
/********** END of USER CHANGABLE PARAMETERS *********/

foo=rxfuncquery('rxgdloadfuncs')
if foo=1 then do
  Call RxFuncAdd 'RxgdLoadFuncs', 'RXGDUTIL', 'RxgdLoadFuncs'
  Call RxgdLoadFuncs
end
/* Load up advanced REXX functions */
foo=rxfuncquery('sysloadfuncs')
if foo=1 then do
  call RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs'
  call SysLoadFuncs
end
if datatype(CACHE_SIZE)<>'NUM'  then cache_size=0
if datatype(CACHE_DURATION)<>'NUM'  then cache_size=0
if datatype(DEF_VERBOSE)<>'NUM'  then def_verbose=1
if datatype(back_scale)<>'NUM'  then back_scale=0

if cache_size<1  then cache_size=0
if cache_duration<1 then cache_size=0

sqs.!got=rxfuncquery('SQRT')  /* is there a sqrt function available */

send_delay=12           /* time to wait before SENDing a piece */

if filespec('D',gif_dir_root)=' ' then do
     oof=directory()
     arf=filespec('d',oof)
     gif_dir_root=arf||gif_dir_root
end  /* Do */
if gif_dir_root=' ' then
    gif_dir_root=strip(basedir,'t','\')||'\alphabyt'

gif_dir_root=strip(gif_dir_root,'t','\')||'\'

parse arg  ddir, tempfile, reqstrg,list,verb ,uri,user, ,
          basedir ,workdir,privset,enmadd,transaction,verbose, ,
         servername,host_nickname,homedir

a_box=d2c(254)
if verbose="" then verbose=def_verbose

/* check for CGI-BIN call */
is_cgi=0
if verb="" then do    /* is it cgi-bin? */
   method = value("REQUEST_METHOD",,'os2environment')
   if method="" then do
       list=ask_values()
       if list="" then exit
       is_cgi=2         /* signals "stand alone */
       verbose=2
   end /* do */
   else do
      is_cgi=1
      if method='GET' then do
          list=value("QUERY_STRING",,'os2environment')
      end
      else do
         tlen = value("CONTENT_LENGTH",,'os2environment')
         list=charin(,,tlen)
      end /* do */
      verbose=def_verbose
   end
end

if is_cgi=0 then do
  if  verb="GET" then    parse var uri . '?' list   /* if srefilter addon, get purer version of request string */
end

aa=sysfiletree(gif_dir_root||'*.*','arf','b')
if arf.0=0 then do
   call gpmprintf(" GIF_TEXT: GIF_DIR_ROOT is empty or missing: "gif_dir_root)
   if is_cgi=1 then
        return
   return 0
end /* do */


/*  request options understood:
   FONT_DIR, SEND, FONT_NAME, FONT_INDEX, TIME_FMT, DATE_FMT, BACKCOLOR,
   TEXTCOLOR, TRANSPARENT, WIDTH, HEIGHT, LITERAL,X_FRAME,y_FRAME
    X_SCALES Y_SCALES V_ALIGN LINE_JA
    SLIDE SLIDE_VERT SLIDE_HORIZ SLIDE_THRESH SLIDE_PROB
    SLIDE_COORD SLIDE_SIZE SLIDE_RED SLIDE_GREEN SLIDE_BLUE SPECIAL
 */

/* set to blank means "use font_index value if none specified in request */
send_bim=0
back_file=' ' ; text=' '
amessage=' ' ; cache_file=' ';  do_cache=0
backcolor=' ' ; textcolor=' ' ; transparent=""
fontdir=default_font; fontname=font_name ; fontindex=font_index
many_type=0 ; many_type_max=0
x_scales="" ;y_scales="" ; y_valign="" ; slide="" ;  slide_vert="" ;
slide_thresh=' ' ; slide_horiz=''
slide_red="" ; slide_green="" ;slide_blue=""
slide_size=""
slide_coord=""
slide_xcoord="" ; slide_ycoord="" ; slide_prob=''
special=''
linealign='L'

/* pull options from request */
literal=0 ;
 do until list=""                /* get user input */
   parse var list a1 '&' list
   parse var a1 a1a '=' a1b0
   a1a=translate(strip(a1a))
   a1b1=packur2(a1b0)
   a1b=strip(translate(a1b1))
   select
      when a1a="FONT_DIR" | a1a="FONT" then do
          if a1b<>' ' then fontdir=a1b
      end  /* Do */
      when a1a="FONT_NAME" | a1a="NAME" then do
           if a1b<>' ' then fontname=a1b
      end
      when a1a="FONT_INDEX" | a1a="INDEX" then do
            if a1b<>' ' then fontindex=a1b
      end  /* Do */
      when abbrev(a1a,'TIME')=1 then time_fmt=a1b
      when abbrev(a1a,'CACHE')=1 then do
                cache_file=strip(a1b)
                do_cache=1
                if a1a='CACHE2' then do_cache=2
      end  /* Do */
      when abbrev(a1a,'DATE')=1 then date_fmt=a1b
      when abbrev(a1a,"TEXTC")=1 then textcolor=a1b
      when abbrev(a1a,"BACKG")+abbrev(a1a,"BACKC")>0 then backcolor=a1b
      when abbrev(a1a,"TRANS")=1 then do
         if datatype(a1b)='NUM' then transparent=a1b
      end
      when a1a="WIDTH" | a1a="W" then width=a1b
      when abbrev(a1a,'SPECIAL')=1 then special=special' 'a1b
      when a1a="SEND" then send_pieces=a1b
      when abbrev(a1a,'MANY_')=1 then do
          if datatype(a1b)='NUM' then
               many_type_max=a1b
          else
               many_type=wordpos(translate(a1b),'CYCLE FIT END RANDOM')
      end /* do */
      when abbrev(a1a,"X_F")=1 then do
           if datatype(a1b)='NUM' then x_frame=a1b
      end
      when abbrev(a1a,"Y_F")=1 then
          if datatype(a1b)='NUM' then y_Frame=a1b

      when a1a="HEIGHT" | a1a="H" then height=a1b
      when abbrev(a1a,"LIT")=1 then literal=a1b
      when a1a="BACK" | a1a="BACK_FILE" then back_file=a1b
      when a1a="BACK_SCALE" | a1a="BKSC" then back_scale=wordpos(translate(a1b),'Y YES 1')
      when abbrev(a1a,'X_SC')+abbrev(a1a,'XSCA')>0 then x_scales=a1b
      when abbrev(a1a,'Y_SC')+abbrev(a1a,'YSCA')>0 then y_scales=a1b
      when abbrev(a1a,'VALI')+abbrev(a1a,'V_ALI') + abbrev(a1a,'Y_VAL')+ abbrev(a1a,'YVAL')>0 then y_valign=a1b
      when abbrev(a1a,'SLIDE_H')=1  then slide_horiz=a1b
      when abbrev(a1a,'SLIDE_T')=1  then slide_thresh=a1b
      when abbrev(a1a,'SLIDE_V')=1  then slide_vert=a1b
      when abbrev(a1a,'SLIDE_F')=1 | a1a='SLIDE'  then  do
          ee=translate(a1b,'\','/')
          ee=strip(a1b,'l','\')
          slide=gif_dir_root||ee
      end
      when abbrev(a1a,'SLIDE_S')=1  then do
          if datatype(a1b)='NUM'  then slide_size=a1b
      end  /* Do */
      when abbrev(a1a,'SLIDE_C')=1  then slide_coord=a1b
      when abbrev(a1a,'JUST')=1 | abbrev(a1a,'LINE_J')=1 then line_just=translate(left(a1b,1))
      when abbrev(a1a,'SLIDE_R')=1  then slide_red=a1b
      when abbrev(a1a,'SLIDE_G')=1  then slide_green=a1b
      when abbrev(a1a,'SLIDE_B')=1  then slide_blue=a1b
      when abbrev(a1a,'SLIDE_P')=1  then slide_prob=a1b

      when a1a="MESSAGE" | a1a="TEXT" then do
         a1b0=strip(a1b0,,'"')
         amessage=packur2(a1b0)
      end
      otherwise nop
   end  /* select */
end /* do */
if amessage="" then amessage=' '

if verbose>1 then call gpmprintf(' GIF_TEXT font= ' fontdir ', message: 'amessage)

/* if send_pieces, then see if the browser supports multi part documents (connection:keep-alive) */
if is_cgi=0 & wordPos(translate(send_pieces),'Y YES 1')>0 then do
    a=translate(strip(reqfield('Connection')))
    a2=translate(strip(reqfield('PROXY-Connection')))
    if a<>'KEEP-ALIVE' & a<>'MAINTAIN' ,
       & a2<>'KEEP-ALIVE' & a2<>'MAINTAIN' then do
         send_pieces=0            /* browser does NOT support connection:keep-alive */
         nsent=0
    end
    else do
        send_pieces=1   /*  it does */
    end /* do */
end
else  do
   send_pieces=0      /* send_Pieces ONLY works as SRE-http addon */
end  /* Do */

call fix_defaults               /* set some default parameters */

call fix_options                /* using font_index and request stuff, set options */

call fix_message                /* fix up message (special code replacmenet */

call check_ndims

/* DONE WITH INITIALIZATIONS  ----------------------- */

/* for each charater in message, get it's gif file (if avaiable), it's
   size, and it's scale factors */
len0 = Length(amessage)          /* amessage is message, after $t, etc modifications */
xmess=0; ymess=0 ; cfound=0
ysize_tot=0 ; xsize_tot=0
l=0; newls=''
do l0 = 1 to len0

   achar = substr(amessage,l0,1)
   ichar=c2d(achar)
   if ichar=10 then do          /* newline */
       newls=newls' 'l   /* record position, and drop character */
       iterate
   end /* do */

   if ichar=6 then do           /* font switch -- use carefully */
       parse var user_fonts fontname user_fonts
       switchl.l=fontname
       fontindex='';fontdir=fontname
       call fix_defaults 1              /* set some default parameters */
       call fix_options
       call check_ndims
       iterate
   end /* do */

   l=l+1
   switchl.l=''

   cls.l=' '              /* the l'th characters GIF file. ''=n.a. */
   cls.!xscale.l=get_user_scale(l,len0,x_scales) /* char specific width scale factor */
   cls.!yscale.l=get_user_scale(l,len0,y_scales) /* char specific height scale factor */
   cls.!xsize.l=0                       /* char width (0=n.a. */
   cls.!ysize.l=0                       /* char height (0=n.a. */
   cls.!char.l=achar

/* note: xscale and yscale are image independent (uses character position in
  the message, and the user_scale parameter) */

   select
      when ichar=1 | ichar=2 then do    /* am or pm character */
          achar='PM' ; if ichar=1 then achar='AM'
          cl=get_gifname(achar,gif_dir,fontname)  /* may use UC for LC, etc. */
          if cl=' ' then iterate
      end  /* Do */
      when ichar=254 then do            /* filled box characher */
          cls.l=achar
          iterate
      end /* do */
      when ichar>139 then do            /* special $x character */
         ichar0=ichar-140
         if symbol('FONT_IND.!chars.'||ichar0)<>'VAR' then iterate /* error, skip*/
         cl=gif_dir||font_ind.!chars.ichar0
         if stream(cl,'c','query exists')=' ' then iterate
      end  /* Do */
      otherwise do             /* normal character -- check for file */
         if achar=' ' then iterate
         cl=get_gifname(achar,gif_dir,fontname)
         if cl=' ' then iterate
      end
   end
/* double check -- is it a gif file? */
   im = RxgdImageCreateFromGIF(cl)
   IF (im = 1 | im=0) THEN do
      IF VERBOSE>0 then call gpmprintf("GIF_TEXT bad GIF file: " cl' 'im)
      iterate
   end

   cls.l=cl             /* use the CL gif file for this l'th character */

   cfound=cfound+1

   cls.!xsize.l=RxgdImageSX(im)
   cls.!ysize.l=RxgdImageSY(im)

   xsize_tot=xsize_tot+cls.!xsize.l
   ysize_tot=ysize_tot+cls.!ysize.l

   Call RxgdImageDestroy im
end

len=l

/* Now, use CLS. and newls to determine HEIGHT AND WIDTH OF MESSAGE */
xmess=X_FRAME*2 ; ymess=Y_FRAME*2 ; yf2=ymess  /* frames are absolute sizes */

do mm=1 to len          /* note: n.a. characters do not contribute to these calcluations */
    xmess=xmess+trunc(cls.!xsize.mm*cls.!xscale.mm)
    if trunc(yf2+(cls.!yscale.mm*cls.!ysize.mm))>ymess then
          ymess=yf2+trunc(cls.!yscale.mm*cls.!ysize.mm)
end /* do */

/* adjust for spaces and missing chars (assuming 1 line of text)*/
select
  when cfound=0 then do                 /* no characters found */
     ysize0=def_text_size ; xsize0=def_text_size
     IF FONT_IND.!ndims>0 then DO               /* not generic default, use complete font info */
         xSIZE0=FONT_ind.!WCHAR-(font_ind.!leftoffset+font_ind.!rightoffset)  /*correct for discarded offsets */
         Ysize0=FONT_IND.!HCHAR-(font_ind.!topoffset+font_ind.!bottomoffset)
     END
     do mmm=1 to len            /* fill in CLS. (sort of a stupid approach) */
        cls.!xsize.mmm=xsize0
        cls.!ysize.mmm=ysize0
        xmess=xmess+(xsize0*cls.!xscale.mmm)
        ymess=max(ymess,yf2+trunc(ysize0*cls.!yscale.mmm))
     end /* do */
  end  /* Do */

  when len=found then nop               /* all characters found */

  otherwise do                          /* some characters found */
     xavgsize=trunc(xsize_tot/cfound)    /* average size of found characters */
     yavgsize=trunc(ysize_tot/cfound)
     do mmm=1 to len              /* set values for n.a. characters */
        if (cls.mmm<>'' & cls.mmm<>a_box)  then iterate   /* got values, so skip */
        xmess=xmess+(xavgsize*cls.!xscale.mmm)
        cls.!xsize.mmm=xavgsize
        cls.!ysize.mmm=yavgsize
     end /* do */
  end   /* otherwise */

end  /* adjusting size for spaces etc. */


numlines=1
/* if multiple lines, refigure xmess and ymess; using cls. info */
if newls<>'' then do
   j1=1 ; ymess=0 ; xmess=0 ; numlines=words(newls)+1
   ymess.0=0
   do mm1=1 to numlines         /*recomputing mess with and height */
      xmess.mm1=0 ;ymess.mm1=0
      if mm1=numlines then
         j2=len
      else
         j2=strip(word(newls,mm1))
      do wr=j1 to j2
         xmess.mm1=xmess.mm1+trunc(cls.!xsize.wr*cls.!xscale.wr)
         if trunc(cls.!yscale.wr*cls.!ysize.wr)>ymess.mm1 then
             ymess.mm1=trunc(cls.!yscale.wr*cls.!ysize.wr)
      end
      xmess=max(xmess,xmess.mm1)
      ymess=ymess+ymess.mm1+2  /* 2 pixel high line sepeartor */
      j1=j2+1
   end
   ymess.0=ymess
   ymess=ymess+yf2            /* character heights + frame */
   xmess.0=xmess
   xmess=xmess+(2*x_Frame)
end /* do */



/* we now know the total image size (xmess and ymess), and the
size/scale/file for each character in the message (cls.) */

/* determine whole  image scale factors, if any */
width_fact=1
height_fact=1
if datatype(width)='NUM' then do
  if width>0 then do
      width_fact=(width-(2*x_Frame))/(xmess-(2*X_FRAME))   /* will force xmess into frame corrected width */
      xmess=width
  end  /* Do */
end  /* Do */
if datatype(height)='NUM' then do
  if height>0 then do
     height_fact=(height-yf2)/(ymess-yf2)
     ymess=height
  end  /* Do */
end

y_useable=ymess-(2*y_frame)  /* height that can be written to */
/* xmess and ymess are the width/height of message (either determined
from message+FRAME, or preset. Width_fact and height_fact will force actual
characters to fit into this rectangle */

/* create a message buffer of required, or desired, size */
   messim=rxgdimagecreate(xmess,ymess)
   if messim=1 | messim=0 then do
      if verbose>0 then  call gpmprintf(" could not create new message buffer ")
      if is_cgi=0 then do
         'NODATA'
         return '400 0'
      end
      else do
           return
      end /* do */
   end  /* Do */
   if slide<>' ' | slide_size>0 then do                /* if color slide, use seperate back file */
         messim_b=rxgdimagecreate(xmess,ymess)
         if messim_b=1 | messim_b=0 then slide=' '
   end

/* set background, default text, and transparent colors */
   oy=rxgdimagecolorallocate(messim,red_back,green_back,blue_back)
   if slide<>' ' | slide_size>0 then  oy=rxgdimagecolorallocate(messim_b,red_back,green_back,blue_back)

   if transparent >-1  then do
       call rxgdimagecolortransparent messim,transparent
       if slide_size>0 | slide<>' ' then call rxgdimagecolortransparent messim_b,transparent
   end

/* fill in the background ? */

back_file=strip(translate(back_file,'\','/'),,'\')
bkf0=back_file
bf2=back_file
if back_file<>' ' then back_file=stream(gif_dir_root||back_file,'c','query exists')
if back_file="" & bf2<>"" & pos(".gif",bf2)=0 then
   back_file=stream(gif_dir_root||bF2||'.gif','c','query exists')

mmb=messim
if slide_size>0 | slide<>' ' then mmb=messim_b   /* where to write background */

if back_file<>' ' then do
   imb = RxgdImageCreateFromGIF(back_file)
   IF (imb = 1 | imb=0) THEN do
      IF VERBOSE>0 then call gpmprintf("GIF_TEXT bad background GIF file: " back_file' 'imb)
      back_file=' '
   end
   else do              /* write scaled, or tiled/portion */
       if back_scale>0 then do     /* scale image to fit into box */
          srcw=RxgdImageSX(imb)
          srch=RxgdImageSY(imb)
          foo=rxgdimagecopyresized(mmb,imb,0,0,0,0,xmess,ymess,srcw,srch)
       end  /* Do */
       else do
          new1=rxgdimagesettile(mmb,imb)
          h1=trunc(xmess/2)+1  ; w1=trunc(ymess/2)+1
          fpp=rxgdimagefill(mmb,h1,w1,new1)  /* fill with multi-pixel color */
       end  /* Do */
   end  /* Do */
   oy=rxgdimagecolorstotal(mmb)
   if verbose>1 then call gpmprintf(' GIF_TEXT: # of colors in background ('bkf0') = ' oy)
end

/* background is done; should it be sent as a preliminary version? */
if send_pieces=1 then do
   oof=img_to_var(mmb,tempfile,1)   /* copy image handle to var; signal errdone if problem */
   fexp=value(enmadd||'FIX_EXPIRE',,'os2environment')
   foo=sref_multi_send(oof,'image/gif','S',,verbose,fexp)
   if foo<0  then signal errdone
   send_bim=rxgdimagecreatefromgif(tempfile)
   foo=sysfiledelete(tempfile)
   nsent=1
  if verbose>1 then call gpmprintf(' GIF_TEXT: SENDing background ')
end /* do */

/* Now copy the appripriate alphabet gifs to the message buffer */

nowx=x_frame ; online=1
nowy=0
if numlines>1 then do
 if line_just='C' | line_just='R' then do       /* center align */
    f1=(xmess.0-xmess.online)/xmess.0 /* diff twixt max width as fraction */
    gg=1
    if line_just='C' then gg=2
    f2=f1*xmess/gg                /* scaled back to actual width */
    nowx=nowx+trunc(f2)
 end /* do */
end                     /* 1st of numlines x correction */

do l=1 to len                   /* for each character in "corrected" message */
  if numlines>1 then do
    isl=l-1
    army=wordpos(isl,newls)
    if army>0 then do           /* new lines, set x and y "line start */
       online=online+1
       nowx=x_frame
       if line_just='C' | line_just='R' then do       /* center align */
          f1=(xmess.0-xmess.online)/xmess.0 /* diff twixt max width as fraction */
          gg=1
          if line_just='C' then gg=2
          f2=f1*xmess/gg                /* scaled back to actual width */
          nowx=nowx+trunc(f2)
       end /* do */
       ol1=online-1
       nowy=nowy+trunc((ymess.ol1/ymess.0)*y_useable)
    end /* do */
  end
  achar=cls.!char.l ; fromdef=0  /* fromdef: 0=own.gif, 1=complete font, 2= generic */
  uul=l-1
  if switchl.uul<>' ' & uul>0 then do
       fontname=switchl.uul
       fontindex='';fontdir=fontname
       call fix_defaults 1              /* set some default parameters */
       call fix_options
       call check_ndims
   end

  if achar=' '  then do          /* a space: skip pixels in image  */
      nowx=nowx+trunc(width_fact*cls.!xscale.l*cls.!xsize.l)
      iterate
  end

  if achar=a_box then do                        /* filled box,  treat as a special "default" character */
      im=rxgdimagecreate(16,16)
      oy=rxgdimagecolorallocate(im,red_back,green_back,blue_back)
      text_color=rxgdimagecolorallocate(im,red_text,green_text,blue_text)
      foo=rxgdimagefilledrectangle(im,0,0,15,15,1)
      xsize=16 ; ysize=16
      fromdef=2
      xsc1=cls.!xsize.l/xsize
      ysc1=cls.!ysize.l/ysize
      cls.!xscale.l=cls.!xscale.l*xsc1
      cls.!yscale.l=cls.!yscale.l*ysc1
      cls.!xsize.l=xsize
      cls.!ysize.l=ysize
  end

  else do                       /* a character */
     cl=cls.l
     if cl=' ' then     /* n.a. character */
         im=1               /* signal "n.a." .gif file */
     else
        im = RxgdImageCreateFromGIF(cl)
  end

  ichar=c2d(achar)              /* might be speial character */

/*  if no such file, use generic or complete font */
  select

     when im<=1 & (ichar<10 | ichar>139) & (ichar<>254) then do   /* missing special charcter == use space character */
        nowx=trunc(width_fact*cls.!xscale.l*cls.!xsize.l)+nowx
        iterate
     end  /* Do */

     when im <= 1  THEN   do       /* missing, use generic or DEFAULT font */
        uul=l-1

        im=get_default_char(achar,l,len,many_type_max)   /* alphabyte specific default? */

        if im<>1 then do    /* got an image containing the font */
          if  verbose>1 then call gpmprintf(' GIF_TEXT: using alphabyte specific default for character ' achar)
          xsize=RxgdImageSX(im)      /* complete font (useable) size */
          ysize=RxgdImageSY(im)
          fromdef=1
        end

        else do         /* no complete font -- use generic default */
          if  verbose>1 then call gpmprintf(' GIF_TEXT: using default for character ' achar)
          im=rxgdimagecreate(16,16)
          oy=rxgdimagecolorallocate(im,red_back,green_back,blue_back)
          text_color=rxgdimagecolorallocate(im,red_text,green_text,blue_text)
          foo=rxgdimagestring(im,'G',0,0,achar,text_color)
          xsize=16 ; ysize=16
          fromdef=2
        end

/* scale must scale xsize,ysize to presumed size (cls.!xsize,!ysize);
  and still include character specific scale */
        xsc1=cls.!xsize.l/xsize
        ysc1=cls.!ysize.l/ysize
        cls.!xscale.l=cls.!xscale.l*xsc1
        cls.!yscale.l=cls.!yscale.l*ysc1
        cls.!xsize.l=xsize
        cls.!ysize.l=ysize
     end

     otherwise  do               /* use matching .gif file */
        xsize=cls.!xsize.l
        ysize=cls.!ysize.l
        fromdef=0
     end

  end           /* select */

/* copy to message buffer. Rxgd will take care of color table matching, etc */

/* fix background & transparency */
  foo=0
  if back_File<>' '& fromdef>0  & transparent>-1 then do
    tt=transparent
    if font_ind.!isbw=0 then do
       tt=rxgdimagecolorclosest(im,dim_r,dim_g,dim_b)
    end
    call rxgdimagecolortransparent im,tt
    foo=tt
  end
  else do
   if back_file<>' ' then foo=rxgdimagegettransparent(im)
  end
  if foo=-1 & back_file<>" " & fromdef=0 then do   /* try to fix transparency */
     call rxgdimagecolortransparent im,font_ind.!transparent
  end


/* now, write possibly scaled image to messim.  There are two scales:
  character specific scale: a combo of the "generic/default to average"
                            and the "user-specified character specific scale"
  whole message scale: fit message to specified message width/height
  and ... adjust vert and horiz for line and line alignment
*/

  wfact=width_fact*cls.!xscale.l
  hfact=height_fact*cls.!yscale.l
  xsize=cls.!xsize.l ; ysize=cls.!ysize.l
  yff=y_frame
  ish=y_useable
  if numlines>1 then ish=trunc((ymess.online/ymess.0)*y_useable)

  if wfact=1 &hfact=1 then do
      select
         when y_valign='B' then do
              yff=yff+(ish-ysize)
         end  /* Do */
         when y_valign='M' then do
              yff=y_frame+((ish-ysize)/2)
         end  /* Do */
         otherwise nop
      end  /* select */
      foo=rxgdimagecopy(messim,im,nowx,nowy+yff,0,0,xsize,ysize)
      nowx=nowx+xsize
  end
  else do   /* scale it */
      dxsize=trunc(xsize*wfact)
      dysize=trunc(ysize*hfact)
      ish=y_useable
      if numlines>1 then ish=trunc((ymess.online/ymess.0)*y_useable)
      select
         when   y_valign='T' then yff=y_frame
         when y_valign='B' then do
              yff=y_frame+(ish-dysize)
         end  /* Do */
         when y_valign='M' then do
              yff=y_frame+((ish-dysize)/2)
         end  /* Do */
         otherwise yff=y_frame
      end  /* select */
      foo=rxgdimagecopyresized(messim,im,nowx,nowy+yff,0,0, ,
                               dxsize,dysize,xsize,ysize)
      nowx=nowx+dxsize
  end  /* Do */

  Call RxgdImageDestroy im

end             /* l'th character of message */

/* if slide used, slideify messim, and then copyit to messim_b */

/* message is done; should it be sent as a secondary version? */
if send_pieces=1 & (slide<>"" | slide_size>0) then do
   foo=rxgdimagecopy(send_bim,messim,0,0,0,0,xmess,ymess)
   oof=img_to_var(send_bim,tempfile)
   foo=sref_multi_send(oof,'image/gif','M')
   if foo<0 then signal errdone
   nsent=2
   if verbose>1 then call gpmprintf(' GIF_TEXT: SENDing message text ')
end /* do */

/* get first row of slide, and fix up color table */
if slide<>' ' then do              /* read slide from file */
   slim=rxgdimagecreatefromgif(slide)
   if (slim=0 | slim=1 )  then do
          slide=''              /* no slide avaialble */
          if verbose>1 then
             call gpmprintf(' No Slide file available ')
   end  /* Do */
end  /* Do */

if slide="" & slide_size>0 then do   /* make your own slide */
   slidect.0=slide_size ; slide.0=slide_size
   do mm=1 to slide_size
      mm0=mm-1
      slidect.!r.mm0=map255(get_user_scale(mm,slide_size,slide_red))
      slidect.!g.mm0=map255(get_user_scale(mm,slide_size,slide_green))
      slidect.!b.mm0=map255(get_user_scale(mm,slide_size,slide_blue))
      slide.mm=mm-1
   end /* do */
   slide_vert='N'       /* force it to be "one row" color slide */
   foo=grab_slide(0,slide_horiz,xmess,1,ymess,,slide_xcoord,slide_ycoord)
end

/* valid color slide .gif file, so get the slide */
if slide<>' ' | slide_size>0 then do

   if slide<>' ' then do   /* get slide just once */
       foo=grab_slide(slim,slide_horiz,xmess,0,ymess,,slide_xcoord,slide_ycoord)
       foo=rxgdimagecolorstotal(slim)

/* read the color slide's color table,*/
       foo=rxgdimagegetcolortable(slim,'tt')
       r='R'; g='G'; b='B'
       slidect.0=tt.0
       do il=0 to slidect.0-1
          slidect.!r.il=tt.r.il
          slidect.!g.il=tt.g.il
          slidect.!b.il=tt.b.il
       end
    end

/* if slide_size>0, then we use slidect that was created above */

/* get color table of messim (if slide_thresh_type<>'P') */
   if slide_thresh_type<>'P' then do
      foo=rxgdimagegetcolortable(messim,'tt')
      r='R'; g='G'; b='B'
      messct.0=tt.0
      do il=0 to messct.0-1
        messct.!r.il=tt.r.il
        messct.!g.il=tt.g.il
        messct.!b.il=tt.b.il
      end
   end /* do */

   foo=add_slide_ct(messim)             /* add/remapslide colors to message image */
   if slide_xcoord<>'' & slide_Ycoord<>'' then do
       ixcoord=slide_xcoord*xmess ; iycoord=slide_ycoord*ymess
   end
   nchanges=0
   if slide_prob="" then do
       ixcoord=0 ; iycoord=ny
   end /* do */

/* Get each row of message image, check and (possibly) convert each pixel to slide colors */
   hey=time('r')                /* timer used for SEND */

   nofinal=0            /* a special effect -- causes a left side shadow */
   if send_pieces=1 & wordpos('NOFINAL',translate(special))>0 then nofinal=1
   do ny=0 to ymess-1           /* for each row of message image */
     if slide_coord="" then do
         ixcoord=0 ; iycoord=ny
     end /* do */
     if verbose>1 & ny//25=1 &send_pieces<>1 then call gpmprintf(" GIF_TEXT: Transforming message row " ny ' of ' ymess)
     if slide_vert<>'N' then do
        foo=grab_slide(slim,slide_horiz,xmess,ny,ymess,slide_vert)      /* get slide for this rowl */
     end  /* Do */
     foo=rxgdimagegetrowpixels(messim,ny,pxels)
     do nx=1 to xmess
       apix=pxels.nx
       if slide_thresh="P1" & apix=0 then iterate  /* the most common case */
       doit=do_change(apix,slide_thresh_type,slide_thresh_val,nx,xmess)
       if doit=1 then do
           if (slide_xcoord="" | slide_ycoord="") & slide_prob="" then do
               itmp=slide.nx
           end
           else do
               nnx=max(1,trunc(figdist(nx,ny,ixcoord,iycoord)))
               doit=do_change(1,'P',1,nnx,slide.0,slide_prob,1)  /* check probability */
               if doit=0 then iterate
               itmp=slide.nnx
           end /* do */
           apix=slidect.!alt.itmp ; nchanges=nchanges+1
        end  /* Do */
        pxels.nx=apix
     end
     drop pxels.0

      styled  = RxgdImageSetStyle(messim, pxels, xmess)         /* write transformed row back to */
      rc = RxgdImageLine(messim, 0,ny,xmess-1,ny,styled)        /*  the message image */

     if send_pieces=1 then do            /* SEND what ya got? */
           hey2=time('e')
           if hey2>send_delay | (nofinal=1 & ny=ymess-1) then do
                foo=rxgdimagecopy(send_bim,messim,0,0,0,0,xmess,ymess)
                oof=img_to_var(send_bim,tempfile)
                foo=sref_multi_send(oof,'image/gif','M')
                if foo<0 then signal errdone
                nsent=nsent+1
                if verbose>1 then call gpmprintf(' GIF_TEXT: SENDing transformed message text ' ny ' of 'ymess)
                hey=time('r')
           end /* do */
     end /* do */

   end              /* transforming row ny */
   if  nofinal=1 then
      foo=rxgdimagecopy(messim_b,send_bim,0,0,0,0,xmess,ymess)  /* final copy */
   else
      foo=rxgdimagecopy(messim_b,messim,0,0,0,0,xmess,ymess)  /* final copy */
   mmb=messim_b

end  /* Do */

else do
    mmb=messim
end

/* copy buffer to a file, and clean up */
if do_cache=0 then do
  gif_file=gif_dir_root||"MES?????.GIF"
  gfile=systempfilename(gif_file)
end
else do
   gfile=gif_dir_root||cache_file
end

foo=rxgdimagegif(mmb,gfile)

foo= RxgdImageDestroy(messim)
if slide<>' ' then foo= RxgdImageDestroy(messim_b)
do mm1=1 to font_ind.!ndims
  jdim=dim.mm1
  foo= RxgdImageDestroy(jdim)
end /* do */

if send_bim<>0 then foo=rxgdimagedestroy(send_bim)
if back_file<>' ' then  foo=rxgdimagedestroy(imb)
if slide<>' ' then foo=rxgdimagedestroy(slim)
IF VERBOSE>1 then CALL GPMPRINTF(' GIF_TEXT: completed image of size ' xmess ' x ' ymess )

shipit: nop             /* jump here if cache entry found */

if is_cgi=0 then do             /* srefilte addon */
  signal on failure name nocon
  if send_pieces=1 then do            /* final send? */
      oof=charin(gfile,1,chars(gfile))
      foof=stream(gfile,'c','close')
      foo=sref_multi_send(oof,'image/gif','E')
      ieek=stream(gfile,'c','query size')
      if do_cache=0 then   foo=sysfiledelete(gfile)
      if foo<0  then signal errdone
      nsent=3
      return 200' 'ieek
  end /* do */
/* else, use 'FILE  */
  if do_cache=0 then do
     return 'FILE ERASE TYPE image/gif name ' gfile     /* let sre deal with reply */
   end
   else do
     return 'FILE  TYPE image/gif NOCACHE name ' gfile
   end
   oof=stream(gfile,'c','query size')
  return '200 '||oof
end
if is_cgi=1 then do             /* cgi-bin */
  Say "Content-type: image/gif"
  Say
  ki=chars(gfile); foo=stream(gfile,'c','close')
  foo=charin(gfile,1,ki)
  foo2=stream(gfile,'c','close')
  call charout,foo
  if result<>0 then
     call gpmprintf(" GIF_TEXT CGI-BIN error: not all of file written: "||foo3)
  if do_cache=0 then  foo=sysfiledelete(gfile)
  return
end /* do */

if is_cgi=2  then do            /* stand alone */
  foo2=stream(gfile2,'c','close')
  ki=stream(gfile,'c','query size')
  foo=charin(gfile,1,ki)
  aa=charout(gfile2,foo,1)
  IF AA>0 then
      SAY " Problem writing to outfile: " gfile2
  else
     say gfile2 " created (length = " ||stream(gfile2,'c','query size')
  foo=stream(gfile2,'c','close')
  foo=stream(gfile,'c','close')

  foo=sysfiledelete(gfile)

   exit
end  /* Do */


errdone:
if is_cgi=1 then do
  Say "Content-type: text/plain"
  Say
  say "GIF_TEXT error at line  " sigl " (RC=" rc
  return
end /* do */

say "GIF_TEXT error at line  " sigl " (RC=" rc
if is_cgi=0 then do
   'NODATA'
   return  '400 0'
end
exit

/***********/
check_ndims:
/* check on default font info */
font_ind.!ndims=0
if font_ind.!defgifs<>' ' then do
   do wiww=1 to words(font_ind.!defgifs)

      adefgif=strip(word(font_ind.!defgifs,wiww))
      bdefgif=gif_dir||adefgif

      dim= RxgdImageCreateFromGIF(bdefgif)
      if dim=1 | dim=0 then do
           CALL gpmprintf(' GIF_TEXT: missing alphabyte specific default:'adefgif)
           iterate
      end
      ndims=ndims+1
      att=transparent ; if att<0 then att=0
      dim.ndims=dim
      dim.ndims.!name=adefgif
      if ndims=1 then do
         dim_r=rxgdimagered(dim,att)
         dim_g=rxgdimagegreen(dim,att)
         dim_b=rxgdimageblue(dim,att)
      end

  end  /* Do */
  font_ind.!ndims=ndims
end  /* Do */
return 1

/******************/
/* copy an image to a variable (copy of what would be in .gif file */
img_to_var:procedure expose tempfile is_cgi
parse arg im,afile,keepit
if afile=""  then afile=tempfile
foo1=rxgdimagegif(im,afile)
oof=charin(afile,1,chars(afile))
if oof="" then signal errdone           /* empty -- must be aproblem */
foo=stream(afile,'c','close')
if keepit<>1 then foo=sysfiledelete(afile)
return oof


/**************************************************/
/* set/cleanup DEFAULT parametrs */
fix_defaults:
parse arg nocheck

red_text=200 ;green_text=200 ; blue_text=200
red_back=255 ; green_back=255 ; blue_back=255

def_transparent=check_byte(def_transparent,-1)
def_text_size=check_byte(def_text_size,15)
if fontname=0 then fontname=' '
if fontindex=0 then fontindex=' '
if back_file=0 then back_File=' '

gif_dir=gif_dir_root||strip(fontdir,,'\')||'\'

/* check the cache? */
if nocheck<>1 then do
  if do_cache=1 then
    if pos('$D',translate(amessage))+pos('$T',translate(amessage))>0 then do_cache=0
  if cache_size=0 then do_cache=0

  /* use a cached file? */
  foo=do_from_cache(cache_file)
  if foo=1 then signal shipit
end
oof=translate(fontdir,'  ','\/')
if fontname=' ' then fontname=strip(word(oof,words(oof)))
if fontindex=' ' then fontindex=fontname||'.IND'
fontindex=gif_dir||fontindex
dim=0 ; ndims=0;font_ind.!defgifs=' '
dim_r=0;  dim_g=0 ; dim_b=0
return 1



/***************************/
/* set options, using font_index and request stuff */
fix_options:
/* get font index, and possibly  text and back colors and default-font info */
inind=READ_FONT_INDEX(fontindex)  /* read in font index, and back and text color_index*/
if textcolor="" then textcolor=font_ind.!textcolor
if backcolor="" then backcolor=font_ind.!backcolor
vvs=get_from_hex(textcolor)
if vvs<>' ' then do
   parse var vvs red_text green_text blue_text
end
vvs=get_from_hex(backcolor)
if vvs<>' ' then do
   parse var vvs red_back green_back blue_back
end  /* Do */
/* many_defaults from options ? */
if many_type>0 then font_ind.!manytype=many_type

/* if no x_scales or y_scales in request, use .IND file (if exists) */
if x_scales<>"" then font_ind.!x_user_scale=x_scales
if y_scales<>"" then font_ind.!y_user_scale=y_scales
x_SCALES=FIX_SCALE(FONT_IND.!X_USER_SCALE)
Y_SCALES=FIX_SCALE(FONT_IND.!Y_USER_SCALE)

if y_valign="" then y_valign=font_ind.!y_valign
y_valign=translate(y_valign)
select
  when abbrev(y_valign,'B')=1 then y_valign='B'
  when abbrev(y_valign,'T')=1 then y_valign='T'
  when abbrev(y_valign,'M')+abbrev(y_valign,'C')>0 then y_valign='M'
  otherwise y_valign='T'
end

if slide_vert="" then slide_vert=font_ind.!slide_vert
/* slide_vert= Tile, Fit, None */
slide_vert=left(strip(translate(slide_vert)),1)
if pos(slide_vert,'TFN')=0 then slide_vert='N'  /* use 1 slide is default */

if slide_horiz="" then slide_horiz=font_ind.!slide_horiz
slide_horiz=left(strip(translate(slide_horiz)),1)
/* slide_horiz types: Tile. Resize */

if slide="" then slide=font_ind.!slide
if slide<>'' then do
   stmp=slide
   slide=stream(slide,'c','query exists')
   if  slide=' ' & pos('.',stmp)=0 then do  /* try adding .gif to end */
       slide=stream(stmp||'.gif','c','query exists')
   end  /* Do */
end  /* Do */

if slide_thresh="" then slide_thresh=font_ind.!slide_thresh
slide_thresh=translate(strip(slide_thresh))
slide_thresh_type=left(slide_thresh,1)
slide_thresh_val=substr(slide_thresh,2)
slide_thresh_val=strip(translate(slide_thresh_val,' ','+:'))  /* might be list of values */

if slide_size="" then  slide_size=font_ind.!slide_size
if slide_size<>0 then do
  if slide_green="" then  slide_green=font_ind.!slide_gre en
  if slide_red="" then  slide_red=font_ind.!slide_red
  if slide_blue="" then  slide_blue=font_ind.!slide_blue
  slide_green=fix_scale(slide_green)
  slide_red=fix_scale(slide_red)
  slide_blue=fix_scale(slide_blue)
end

if slide_prob="" then slide_prob=font_ind.!slide_prob
slide_prob=fix_scale(slide_prob)

if slide_coord="" then slide_coord=fonT_ind.!slide_coord
slide_coord=fix_scale(slide_coord)
parse var slide_coord tx ty
if datatype(tx)='NUM' & datatype(ty)='NUM' then do
        slide_xcoord=tx
        slide_ycoord=ty
end /* do */
if pos(slide_thresh_type,'PCB')=0  then do
     slide=''
     call gpmprintf(' Error specifying slide_thresh:'slide_thresh)
end  /* Do */
do ll=1 to words(slide_thresh_val)
  if datatype(strip(word(slide_thresh_val,ll)))<>'NUM' then do
     slide=''
     call gpmprintf(' Error specifying slide_thresh:'slide_thresh)
  end
end

if verbose >1 & slide<>' ' then  do
  call gpmprintf(" GIF_TEXT: Using color slide " slide)
end
else do
  if verbose >1 & slide_size>0  then call gpmprintf(" GIF_TEXT: Using generated color slide, #colors=" slide_size)
end

/* what's the "transparent" color table entry */
if transparent='' then    /* not specified in request */
    transparent=font_ind.!transparent
if transparent>255 | transparent <-1 then transparent=def_transparent /* is it copecetic? */

return 1


/**************************************/
/* fix up message */
/* convert $x into time, date, etc. */
fix_message:
user_fonts=''
goof='00'x
aa=translate(amessage,goof,'0d0a09'x)
aaa=''
do until aa=""
   parse var aa a1 (goof) aa
   aaa=aaa||a1
end /* do */
amessage=aaa
if literal<>1  & pos('$',amessage)<>0 then do
/* parse amessage, converting $x into appropriate stuff. Note that $$ (or $$$..)
   is interpreted at $ (or $$...) */
  newmess=""
  do until amessage=""
       parse var amessage m1 '$' m2
       newmess=newmess||m1
       if m2="" then leave
       if abbrev(m2,'$')=1 then do  /* strip out $ and display */
          amessage=strip(m2,'l','$')
          idls=length(m2)-length(amessage)
          newmess=newmess||copies('$',idls)
          iterate
       end
       akey=translate(left(m2,1))
       select
          when  akey='T' then newmess=newmess||get_time(time_fmt)
          when  akey='D' then newmess=newmess||get_date(date_fmt)
          when  akey='S' then newmess=newmess||'SERVERNAME'
          when pos(akey,'1234567890')>0 then do
             rval=akey
             akey2=translate(substr(m2,2,1))
             if pos(akey2,'1234567890')>0 then do
                 rval=(rval*10)+akey2
                 amessage=substr(m2,2)
             end
             newmess=newmess||d2c(rval+140) /* if val>139, then it's a special */
             iterate
          end
          when akey='B' then  newmess=newmess||d2c(254) /* 254 is "filled box " */
          when akey='N' then  newmess=newmess||d2c(10)  /* line break */
          when akey='F' then do
               parse var amessage . '(' newfont ')' amessage
               user_fonts=user_fonts||' 'newfont
               newmess=newmess||d2c(6)          /* 6 signals "font switch */
               iterate
          end /* do */
          otherwise nop
       end
       amessage=substr(m2,2)
  end /* do */
  amessage=newmess
end  /* interpret $x */
return 1

/***********************************/
/* map a 0.. 1 to 0..255 */
map255:procedure
parse arg a1
return trunc(max(min(a1*255,255),0))

/***********************************/
/* change this pixel ? */
do_change:procedure expose messct. is_cgi
parse arg apix,atype,aval0,jjx,xlen,slide_prob,useaval,jjy
if useaval=1 then
  aval=aval0
else
  aval=get_user_scale(jjx,xlen,aval0) /* pixel specific threshold */

aprob=get_user_scale(jjx,xlen,slide_prob)   /* probability of using scale: 1- always use,0-use original value*/
if aprob<1 then do
   arf=random()/999
   if arf>aprob then return 0           /* retain with current value */
end /* do */

if atype='P' then do
   if apix >= aval then return 1
   return 0
end  /* Do */
r=messct.!r.apix
b=messct.!b.apix
g=messct.!g.apix
if atype='C' then do            /* if brightest color is over threshold */
    if max(r,b,g)>=aval then return 1
    return 0
end  /* Do */
if atype='B' then do            /* if average brightness over threshold */
     if (r+b+g)/3 >= aval then return 1
     return 0
end  /* Do */
return 0                /* shoud never get here */


/***************/
/* process from a cached file
  return 1 if "used a cache file"; 0 if not.
  Also, set do_cache=0 if a problem arises */

do_from_cache:procedure expose gif_dir_root verbose do_cache cache_duration is_cgi
parse arg cache_file
if do_cache=0 then return 0

if do_cache>0 then do
   do_cache=1
   cache_file=gif_dir_root||cache_file
   gfile=cache_file

   eek=sysfiletree(cache_file,afile,'FT')
   if afile.0>0 then do         /* match -- check duration */
        parse var afile.1 dd .
        mkdate=space(translate(left(afile.1,8),' ','/'),0)
        nowdate=space(translate(date('o'),' ','/'),0)
        if abs(nowdate-mkdate) <= cache_duration then do
          if verbose>1 then call gpmprintf(' GIF_TEXT: using cached image file: ' cache_file)
          return 1
       end
       if verbose>1  then call gpmprintf('GIF_TEXT: Rewriting cached image file: ' cache_file)
       return 0
   end  /* Do */
   else do              /* no match -- is there room? */
      foo=sysfiletree(gif_dir_root||'*.*','eek','FO')
      if eek.0 > cache_size then do
         do_cache=0     /* suppress cache! */
         if verbose>1 then call gpmprintf(' GIF_TEXT: cache_size exceeded, can not cache image file: ' cache_file)
      end  /* Do */
      else do
          if verbose>1 then call gpmprintf(' GIF_TEXT: creating cached image file: ' cache_file)
      end /* do */
   end
end
return 0



/***********************************/
/* get the slide file stuff
ATYPE has 3 values:
  T= repeat slide
  F= fit (internally repeat)
*/
grab_slide:procedure expose slide. verbose slidect.   is_cgi sqs.
parse upper arg sim,atype,mx,ajy,my,stype,sxc,syc
if sim<>0 then do
  foo=rxgdimagecolorstotal(sim)
  jx=rxgdimagesx(sim)
  jy=rxgdimagesy(sim)
end
else do
   jy=1
   jx=slide.0
end /* do */
jy0=jy
/* which row to read from ? */
if jy>1 & ( stype="F" | stype="T" ) then do  /* multi row style -- use my ajy row */
    select
     when ajy=0 then jy=0
     when ajy=my then jy=jy-1
     when jy>my | stype='F' then do
       tt=ajy/my
       jy=trunc(tt*(jy-1))
     end
     when stype='T' then do
        jy=trunc(ajy//(jy-1))
     end  /* Do */
     otherwise jy=1
   end
end  /* Do */
else do
   if jy>1 then
       jy=trunc(1+(jy/3))
   else
     jy=0
end

/* if sxc and syc specified, then measrue distance from there (rather then just using
    column #. This means computing max distance from sxc,syc */
if datatype(sxc)='NUM' & datatype(syc)='NUM' then do    /* use distance, not colunm */
    ixc=1+((mx-1)*sxc);   ixc= max(min(ixc,mx),1)
    iyc=1+((my-1)*syc) ;  iyc= max(min(iyc,my),1)
    d1=figdist(ixc,iyc,1,1)
    d2=figdist(ixc,iyc,mx,1)
    d3=figdist(ixc,iyc,mx,my)
    d4=figdist(ixc,iyc,1,my)
    mx=trunc(max(d1,d2,d3,d4))   /* new "max distance from slide */
    if verbose>1 then call gpmprintf(' GIF_TEXT: Max distance from slide_coord='mx)
end

if verbose>1 & ajy//25=1 then
   call gpmprintf(" GIF_TEXT: Getting color slide from row:" jy ' of ' jy0)

drop aslide.
if sim<>0 then do               /* using slide form file */
  foo=rxgdimagegetrowpixels(sim,jy,aslide)
end
else do                         /* using user set slide */
  do mm=0 to slide.0
     aslide.mm=slide.mm
  end /* do */
end

/* we now have base slide (from file or from use set); now expand/shrink to fit mx */
slide.0=mx
/* if slide > mx, then pick from slide */
if jx>mx & atype<>'T' then do
   slide.1=aslide.1
   slide.mx=aslide.jx

   do ll=2 to mx-1
       tt=(ll-1)/(mx-1)
       itt=1+trunc(tt*(jx-1))
       slide.ll=aslide.itt
   end /* do */
   return 1
end  /* Do */

/* slide < mx, need to expand it */
if atype='T' then do            /* tile it, both cases (jx> or < mx)  */
    ii=0
    do mm=1 to mx
       ii=ii+1
       if ii>jx then ii=1
       slide.mm=aslide.ii
    end /* do */
    return 1
end  /* Do */

/* fit (internal repeat */
   slide.1=aslide.1
   slide.mx=aslide.jx
   do ll=2 to mx-1
       tt=(ll-1)/(mx-1)
       itt=1+trunc(tt*(jx-1))
       slide.ll=aslide.itt
   end /* do */
   return 1

/***********/
/* squared distance */
figdist:procedure expose sqs.
parse arg ax,ay,cx,cy
dx=ax-cx ; dy=ay-cy
AAS=( (dx*dx)+(dy*dy))

IF sqs.!got<>0 THEN DO      /* YUCK, USE A NUMERIC SEARCH */
    AAS2=SQRT2(AAS)
end /* do */
ELSE DO
   AAS2=SQRT(AAS)
END
RETURN AAS2

/********************/
/*  a square root finder */
sqrt2:procedure
parse arg aval

if aval<=1 then return aval

/* do a binary search */

i1=1 ;i11=1;
i3=100 ; i33=10000
do until i33>aval | i3=10000000
  i3=i3*5
  i33=i3*i3
end /* do */
i2=i3/2 ; i22=i2*i2

do forever
if aval=i22 then return i2  /* an exact match */
oldi2=i2
if aval <i22 then do
   i3=i2; i33=i22
   i2=i1+((i3-i1)/2) ; i22=i2*i2
end
else do
   i1=i2 ; i11=i22 ;
   i2=i1+((i3-i1)/2) ; i22=i2*i2
end /* do */
if abs(oldi2-i2)<0.01 then return i2
end


/***********************************/
/* add slide's color table to messim */
add_slide_ct:procedure expose slidect. verbose is_cgi
parse arg mim
ist=rxgdimagegettransparent(mim)
usepre=0
do jj=0 to slidect.0-1
   r=slidect.!r.jj ; g=slidect.!g.jj ; b=slidect.!b.jj
   oo=rxgdimagecolorexact(mim,r,g,b)  /* check if color already exists */
   if oo=-1 | oo=ist then do             /*no exact match, or match transparent  */
      aa=rxgdimagecolorallocate(mim,r,g,b)  /* add this color */
      if aa>-1  then do          /* success */
           slidect.!alt.jj=aa
      end  /* Do */
      else do           /* no more colors, use closest */
         slidect.!alt.jj=rxgdimagecolorclosest(mim,r,g,b)
         usepre=usepre+1
      end
   end  /* Do */
   else do
       slidect.!alt.jj=oo              /* use prexisting color */
   end
end /* do */
if usepre>0 & verbose>1  then call gpmprintf(' GIF_TEXT: too many colors, had to share for 'usepre)

return 1




/***********************************/

/* determine a user scale, given ith of Ilen position, and
   list of "user_scales". We assume user_scales is a space delimited list
  of numbers, with 1="use current size", >1 means larger, <1 means smaller */

get_user_scale:procedure expose is_cgi
parse arg ith,ilen,user_scales
if user_scales="" then return 1

igoo=words(user_scales)

if ith=1 then return word(user_scales,1)

if ith=ilen then return word(user_scales,igoo)

/* middle characters*/
frac=(ith-1)/(ilen-1)    /* where in scale list is it */
spot=1+ ((igoo-1)*frac)
ifrac=trunc(spot)
afrac=spot-ifrac

if afrac=0 then return word(user_scales,ifrac)

ii=ifrac+1
a1=word(user_scales,ii)
a2=word(user_scales,ifrac)

diff=a1-a2
return (a2+(diff*afrac))


/***********************************/
/* get the gif name, using several naming tricks */
get_gifname:procedure expose font_ind. is_cgi

parse arg achar,gif_dir,fontname

if length(achar)>1 then achar=translate(achar)
/* check index first */
do iu=1 to font_ind.0
   if font_ind.iu=achar then do
        cl=gif_dir||font_ind.iu.!file
        if stream(cl,'c','query exists')<>' ' then  return cl
        leave
   end  /* Do */
end /* do */
if length(achar)>1 then return ' '  /* special character not found */


/* is it a valid file name (i.e.; don't look for *.gif*/
if pos(translate(achar),'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$%#&@!~-&^')=0 then RETURN ' '

/* it is lowerr case: look for xlc.gif? */

if translate(achar)<>achar then do
   cl=gif_dir||achar||'lc.gif'
   if stream(cl,'c','query exists')<>' ' then  return cl
   cl=gif_dir||fontname||achar||'lc.gif'
   if stream(cl,'c','query exists')<>' ' then  return cl
   cl=gif_dir||fontname||'-'||achar||'lc.gif'
   if stream(cl,'c','query exists')<>' ' then  return cl

end  /* Do */

/* try generic name: look for x.gif? */
cl=gif_dir||achar||'.gif'
if stream(cl,'c','query exists')<>' ' then  return cl
cl=gif_dir||fontname||achar||'.gif'
if stream(cl,'c','query exists')<>' ' then  return cl
cl=gif_dir||fontname||'-'||achar||'.gif'
if stream(cl,'c','query exists')<>' ' then  return cl
cl=gif_dir||achar||fontname||'.gif'
if stream(cl,'c','query exists')<>' ' then  return cl

return ' '



/******/
/* check for valid 0-255 value, set to def if not */
check_byte:procedure
parse arg aval,adef
if adef=' ' then adef=0
if datatype(aval)<>'NUM' then return adef
if aval<0 | aval>255  then return adef
return aval



/*******/
/* read a font index file into font_ind. */
read_font_index:procedure expose font_ind.  gif_dir  def_transparent def_textcolor def_backcolor is_cgi
parse arg afile

defgifs=' '; xoffset=0 ; yoffset=0 ; inrow=16 ; hchar=47  ; wchar=35 ;isbw=1
charset=' !"'||"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
leftoffset=0;rightoffset=0;topoffset=0;bottomoffset=0
transparent="" ; manytype=1
x_user_scales='' ; y_user_scales="" ;y_valign=' ' ;slide='' ;  slide_horiz=''
slide_thresh='P1' ; slide_vert=''
slide_size=""  ; textcolor="" ; backcolor="" ; slide_prob=''

font_ind.0=0
font_ind.!defgifs=defgifs
font_ind.!xoffset=xoffset
font_ind.!yoffset=yoffset
font_ind.!topoffset=topoffset
font_ind.!bottomoffset=bottomoffset
font_ind.!rightoffset=rightoffset
font_ind.!leftoffset=leftoffset
font_ind.!inrow=inrow
font_ind.!hchar=hchar
font_ind.!wchar=wchar
font_ind.!isbw=isbw
font_ind.!charset=charset
font_ind.!manytype=1
font_ind.!x_user_scales=''
font_ind.!y_user_scales=''
font_ind.!y_valign=''
font_ind.!slide=''
font_ind.!slide_horiz=''
font_ind.!slide_vert=''
font_ind.!slide_thresh=''
font_ind.!transparent=def_transparent
font_ind.!textcolor=def_textcolor
font_ind.!backcolor=def_backcolor
font_ind.!slide_size=0
font_ind.!slide_coord=''
font_ind.!slide_blue=''
font_ind.!slide_red=''
font_ind.!slide_green=''
font_ind.!slide_prob=""

if afile=' ' then return 0
ii=0
if stream(afile,'c','query exists')=' ' then return 0
do until lines(afile)=0
  ii=ii+1
  tmp.ii=linein(afile)
end
tmp.0=ii
foo=stream(afile,'c','close')

iin=0
do mm=1 to tmp.0
   aline=strip(tmp.mm)
   if aline=' ' then iterate
   if abbrev(aline,'**')=1 then iterate  /* comment */
   athing=' '
   if pos('=',aline)<>0 then do
       parse var aline athing '=' stuff ; athing=strip(translate(athing))
   end  /* Do */
   select
     when abbrev(athing,'DEFAUL')>0 then  defgifs=defgifs||' '||strip(stuff)
     when athing='DEF_OFFSET' then do
             stuff=translate(stuff,' ',',')
             parse var stuff a1 a2
             if datatype(a1)='NUM'  then xoffset=a1
             if datatype(a2)='NUM'  then yoffset=a2
     end
     when abbrev(athing,'DEF_CHAR_OF')+abbrev(athing,'DEFCHAROF')>0 then do
             stuff=translate(stuff,' ',',')
             parse var stuff a1 a2 a3 a4
             if datatype(a1)='NUM'  then leftoffset=a1
             if datatype(a2)='NUM'  then topoffset=a2
             if datatype(a3)='NUM'  then rightoffset=a3
             if datatype(a4)='NUM'  then bottomoffset=a4
     end  /* Do */
     when abbrev(athing,'DEF_TR')+abbrev(athing,'TRAN')>0 then do
           if datatype(stuff)='NUM'  then transparent=stuff
     end

     when abbrev(athing,'DEF_TEXTC')+abbrev(athing,'TEXT')>0 then do
        if verify(stuff,'0123456789ABCDEFabcdef#')=0 then  textcolor=stuff
     end

     when abbrev(athing,'DEF_BACKC')+abbrev(athing,'BACK')>0 then do
        if verify(stuff,'0123456789ABCDEFabcdef#')=0 then  backcolor=stuff
     end

     when athing='DEF_CHARSIZE' then do
             stuff=translate(stuff,' ',',')
             parse var stuff a1 a2
             if datatype(a1)='NUM'  then wchar=a1
             if datatype(a2)='NUM'  then hchar=a2
     end  /* Do */
     when athing='DEF_CHARS' then charset=stuff
     when athing='DEF_BW' then isbw=pos(strip(translate(stuff)),'Y YES 1')
     when abbrev(athing,"MANY_DEF")+abbrev(athing,'MANYDEF')>0 then do
       manytype=wordpos(translate(stuff),'CYCLE FIT END RANDOM ')
       if manytype=0 then manytype=1
     end
     when athing='DEF_INROW' then
              if datatype(strip(stuff))='NUM' then inrow=strip(stuff)
     when athing='CHAR' then do
      parse var stuff aval afile
      if datatype(aval)<>'NUM' then iterate /* error- ignoe */
      if aval<0  | aval>99 then iterate /* out of range, ignore */
      aval=strip(aval,'l','0')
      font_ind.!chars.aval=strip(afile)
      iterate
     end
     when abbrev(athing,"X_SC")+abbrev(athing,'XSC')>0 then
        x_user_scales=stuff
     when abbrev(athing,"Y_SC")+abbrev(athing,'YSC')>0 then
        y_user_scales=stuff
     when abbrev(athing,'VAL')+abbrev(athing,'Y_VAL')>0 then
        y_valign=stuff
     when abbrev(athing,'SLIDE_H')>0 then
        slide_horiz=packur2(stuff)
     when abbrev(athing,'SLIDE_V')>0 then
        slide_vert=packur2(stuff)
     when abbrev(athing,'SLIDE_T')>0 then
        slide_thresh=packur2(stuff)
     when abbrev(athing,'SLIDE_F')>0 | athing='SLIDE' then do
        slide=packur2(stuff)
        if pos(':',slide)+pos('\',slide)=0 then
           slide=gif_dir||slide
     end
     when abbrev(athing,'SLIDE_R')>0 then
        slide_red=packur2(stuff)
     when abbrev(athing,'SLIDE_G')>0 then
        slide_green=packur2(stuff)
     when abbrev(athing,'SLIDE_B')>0 then
        slide_blue=packur2(stuff)
     when abbrev(athing,'SLIDE_C')>0 then
        slide_coord=packur2(stuff)
     when abbrev(athing,'SLIDE_P')>0 then
        slide_prob=packur2(stuff)
     when abbrev(athing,'SLIDE_S')>0 then do
         tt=packur2(stuff)
         if datatype(tt)='NUM' then slide_size=tt
     end  /* Do */

     otherwise do               /* it's a charater to file map */
        parse var tmp.mm achar afile
        if length(achar)>1 then achar=translate(achar)
        iin=iin+1
        font_ind.iin=strip(achar)   ; font_ind.iin.!file=strip(afile)
     end
   end
end /* do */



if isbw>0 then isbw=1
font_ind.!defgifs=defgifs
font_ind.!xoffset=xoffset
font_ind.!yoffset=yoffset

font_ind.!topoffset=topoffset
font_ind.!bottomoffset=bottomoffset
font_ind.!rightoffset=rightoffset
font_ind.!leftoffset=leftoffset

font_ind.!inrow=inrow
font_ind.!hchar=hchar
font_ind.!wchar=wchar
font_ind.!isbw=isbw
font_ind.!charset=charset
font_ind.!transparent=transparent
font_ind.!manytype=manytype
font_ind.!x_user_scale=x_user_scales
font_ind.!y_user_scale=y_user_scales
font_ind.!y_valign=y_valign
font_ind.!slide=slide
font_ind.!slide_horiz=slide_horiz
font_ind.!slide_thresh=slide_thresh
font_ind.!slide_vert=slide_vert
font_ind.!textcolor=textcolor
font_ind.!backcolor=backcolor

font_ind.!slide_size=slide_size
font_ind.!slide_red=slide_red
font_ind.!slide_green=slide_green
font_ind.!slide_blue=slide_blue
font_ind.!slide_coord=slide_coord
font_ind.!slide_prob=slide_prob

font_ind.0=iin

return iin

/**********/
/* fIX A user scale entry */
fix_scale:procedure
parse arg ascale
if ascale=0 then return 1
ascale=translate(ascale,' ','+')
tt=''
do mm=1 to words(ascale)
   av=strip(word(ascale,mm))
   if datatype(av)<>'NUM' then  iterate
   tt=tt' 'av
end  /* Do */

return tt



/**************************/
/* convert ff21b3 "hex" color code to decimal r g b values
  If bad value, return ' /' */
get_from_hex:procedure
parse arg hval

hval=strip(strip(hval),,'"')
hval=strip(hval,,'#')
select
  when length(hval)<>6 then return ' '
  when verify(translate(hval),'0123456789ABCDEF')>0 then return ' '
  otherwise do
    a1=left(hval,2)
    a2=substr(hval,3,2)
    a3=substr(hval,5,2)
    r=x2d(a1)
    g=x2d(a2)
    b=x2d(a3)
  end
end /* do */
return r ' ' g ' ' b


/********************/
/* return time, using REXX time_fmt. Also, special code: 1 - C without am or pm */
get_time:procedure
parse arg tfmt

if pos(tfmt,'CHLMNS1')=0 then tfmt='N'
if tfmt='1' then do
  aa=time('C')
  a2=translate(right(aa,2))
  oof=2
  if a2="AM" then oof=1         /* reserved special character: 1=am, 2=pm */
  return left(aa,length(aa)-2)||d2c(oof)
end
return time(tfmt)

/********************/
/* return time, using REXX time_fmt */
get_date:procedure
parse arg tfmt

if pos(tfmt,'BDELMNOSUW')=0 then tfmt='N'

return date(tfmt)


/************************************************/
/* procedure from TEST-CGI.CMD by  Frankie Fan <[e-mail]>  7/11/94 */
DecodeKeyVal: procedure
  parse arg Code
  Text=''
  Code=translate(Code, ' ', '+')
  rest='%'
  do while (rest\='')
     Parse var Code T '%' rest
     Text=Text || T
     if (rest\='' ) then
      do
        ch = left( rest,2)
        if verify(ch,'01234567890ABCDEF')=0 then
           c=X2C(ch)
        else
           c=ch
        Text=Text || c
        Code=substr( rest, 3)
      end
  end
  return Text


/*********/
packur2:procedure expose is_cgi
parse arg a1b0

if is_cgi=0 then
   return packur(translate(a1b0,' ','+'))
else
   return decodekeyval(translate(a1b0,' ','+'))

/************/
wow1:
call gpmprintf(" GIF_TEXT error at line "sigl)
      if is_cgi=0 then do
         'NODATA'
         exit '400 0'
      end
      else do
           exit
      end /* do */


/***********************/
/* see if an alphabyte specific default is available */
get_default_char:procedure expose font_ind. verbose dim. red_back green_back blue_back ,
                        red_text green_text blue_text is_cgi
parse arg achar,ithchar,mlen,manymax

if font_ind.!ndims=0 then return 1
ikk=1
nfonts=font_ind.!ndims
if manymax>0 & manymax<nfonts then nfonts=manymax
if nfonts>1 then do
  select
     when font_ind.!manytype=1 then do  /* cycle */
       ikk=ithchar//nfonts
       if ikk=0 then ikk=nfonts
     end
     when font_ind.!manytype=3 then do   /* end */
        ikk=min(nfonts,ithchar)
     end  /* Do */
     when font_ind.!manytype=4 then do  /* random */
        ikk=random(1,nfonts)
     end
     otherwise    do      /* fit */
        ikk=1+trunc(nfonts*ithchar/(mlen+0.1))
     end
  end
end
ic=pos(achar,font_ind.!charset)
if ic=0 then do
  achar=translate(achar)
  ic=pos(achar,font_ind.!charset)
end
if ic=0 then return 1

/* for each character in the charset ... */
/* determine x offset: */
   irow=1+((ic-0.1)%font_ind.!inrow)
   icol=ic-((irow-1)*font_ind.!inrow)

/* upper left is 0,0 */
   xat=font_ind.!xoffset + ((icol-1)*font_ind.!wchar)+font_ind.!leftoffset
   yat=font_ind.!yoffset+ ((irow-1)*font_ind.!hchar)+font_ind.!topoffset
   jx=font_ind.!wchar-(font_ind.!leftoffset+font_ind.!rightoffset)
   jy=font_ind.!hchar-(font_ind.!bottomoffset+font_ind.!topoffset)
   cim=rxgdimagecreate(jx,jy)
   if font_ind.!isbw=0 then do  /* use colors as is, but include back text colors */
      oy1=rxgdimagecolorallocate(cim,red_back,green_back,blue_back)
      oy2=rxgdimagecolorallocate(cim,red_text,green_text,blue_text)
   end

   tdim=dim.ikk         /* use the ikk (of possible many_defaults) complete font */

   foo=rxgdimagecopy(cim,tdim,0,0,xat,yat,jx,jy)
   if font_ind.!isbw=1 then do   /* convert b/w to back/text colors */
ww=rxgdimagegettransparent(cim)
      foo=rxgdimagecolordeallocate(cim,0)
      oy1=rxgdimagecolorallocate(cim,red_back,green_back,blue_back)
      foo=rxgdimagecolordeallocate(cim,1)
      oy2=rxgdimagecolorallocate(cim,red_text,green_text,blue_text)
   end

   return cim


/*********************************/
/* return r g b of aim at ctable ival */
three_color:procedure
parse arg aim,ctable
r=rxgdimagered(aim,ctable)
g=rxgdimagegreen(aim,ctable)
b=rxgdimageblue(aim,ctable)
return r g b

/*********************************/
/* stand alone mode -- build the "list " */
ask_values:procedure expose gfile2 gif_dir_root

SIGNAL OFF  ERROR ; SIGNAL OFF SYNTAX
SIGNAL ON ERROR NAME ASKV
 SIGNAL ON SYNTAX NAME ASKV

ansion=checkansi()
if ansion=1 then do
  aesc='1B'x
  cy_ye=aesc||'[37;46;m'
  normal=aesc||'[0;m'
  bold=aesc||'[1;m'
  re_wh=aesc||'[31;47;m'
  reverse=aesc||'[7;m'
end
else do
  say " Warning: Could not detect ANSI....  output will look ugly ! "
  cy_ye="" ; normal="" ; bold="" ;re_wh="" ;
  reverse=""
end  /* Do */

cls
say  " " ; say

call lineout, bold cy_ye
call lineout, "This is the GIF_TEXT text-to-gif utility: stand alone mode "
call lineout, normal


say " Although designed primarily as a WWW script, you can use GIF_TEXT "
say " to create .GIF files in a stand-alone mode."
say
say "      "||cy_ye||"GIF_TEXT does not have graphics display capability    " normal
say "      "||cy_ye||" ... you'll have to read the files it creates with a  " normal
say "      "||cy_ye||"     graphics viewer (you can often use your browser)." normal
say "  "

if yesno(" Are you ready to continue ")=1 then
 nop
else do
 say " See you later?.. "
 exit
end

/* try reading in prior answers file */
priora=""
if stream('GIF_TEXT.ANS','c','query exists')<>"" then do
say
   say bold ' ... reading prior options from GIF_TEXT.ANS'  normal
   priora=charin('GIF_TEXT.ANS',1,chars('GIF_TEXT.ANS'))
   foo=stream('GIF_TEXT.ANS','c','close')
end /* do */
def.!font="?"; def.!backgrnd="?";def.!colorslide='?'
def.!width=0 ; def.!height=0
def.!moreopts='?'
def.!message='hello'
def.!outgfile='foo.gif'
asep='|^&^|'

do until priora=""
   parse var priora a1 '|^&^|' priora
   parse var a1 a1a '=' a1b
   a2='!'||strip(translate(a1a))
   def.a2=a1b
end /* do */

say
say " We recommend reading the documentation (GIF_TEXT.DOC) before running "
say " running this program.  On the other hand, you can always learn by "
say " making mistakes .... "
say
whatfont:
call charout , "What "reverse "alphabyte font "normal" do you want to use (?=list,ENTER="def.!font"):"
pull font
if font=""  then font=def.!font

if font="?" then do
   say
    say reverse ' List of alphabytes & fonts ' normal
    do while queued()>0
        pull .
    end /* do */
    oog=sysfiletree(gif_dir_root'*.*',qlist,'DO')
    foo=show_dir_queue(1)
    signal whatfont
end  /* Do */
if pos('\',whatfont)+pos(':',font)<>1  then do
     yoob=gif_dir_root||font
     wow=sysfiletree(yoob'\*.*',geeks)
     if geeks.0=0  then do
             say bold " ** Could not find directory for: " normal font
             signal whatfont
     end /* do */
end /* do */


say
getbACK:
call charout , bold"Background file (0=None, ?=list, Enter="def.!backgrnd"):" normal
pull backgrnd
if backgrnd='' then backgrnd=def.!backgrnd
if backgrnd="?" then do
    say
    say reverse ' List of background files in: ' normal bold gif_dir_root'BACKS' normal
    do while queued()>0
        pull .
    end /* do */
    '@DIR /b  '||gif_dir_root||'BACKS\*.gif | rxqueue'
    foo=show_dir_queue('.GIF')
    signal getback
end
if pos('\',backgrnd)+pos(':',backgrnd)=0  & backgrnd<>0 then do
  backgrnd='BACKS\'||backgrnd
  if stream(gif_dir_root||backgrnd||'.gif','c','query exists')='' then do
      say " Could not find background file: " backgrnd
      signal getback
  end /* do */
end

say
getslide:
colorslide=0
call charout , bold"Color slide (0=None, ?=list, ENTER="def.!colorslide"):" normal
pull colorslide
if colorslide=''  then colorslide=def.!colorslide
if colorslide="?" then do
    say
    say reverse ' List of color slides files in: ' normal bold gif_dir_root'SLIDES' normal
    do while queued()>0
        pull .
    end /* do */
    '@DIR /b  '||gif_dir_root||'SLIDES\*.gif | rxqueue'
    foo=show_dir_queue('.GIF')
    signal getslide
end
if pos('\',colorslide)+pos(':',colorslide)=0  & colorslide<>0 then do
  colorslide='slides\'||colorslide
  if stream(gif_dir_root||colorslide||'.gif','c','query exists')='' then do
      say " Could not find color slide file: " colorslide
      signal getslide
  end /* do */
end


say
getht:
call charout , bold"Height (in pixels), 0=automatic, ENTER="def.!height": "normal
pull height
if height="" then height=def.!height
if datatype(height)<>'NUM' then signal getht

getwt:
call charout , bold "Width (in pixels), 0=automatic ENTER="def.!width": "normal
pull width
if width="" then width=def.!width
if datatype(width)<>'NUM' then signal getwt


amess:
Say
Say bold "Enter your message " normal" ($d=date, $t=time, $n=newline, $f(fontname)=font switch "
say bold "   (ENTER=" normal reverse Def.!message normal bold ")" normal
call charout ,bold "The message:"normal
parse pull adesc
if adesc='' then adesc=def.!Message
adesc=a_replacestrg(adesc,'&','%26;','ALL')
message=translate(adesc,'+',' ')

get_opts:
say
say "Additional options (0=none,? for help, * xx = add xx to prior options "
say" ENTER=prior options=" bold def.!moreopts  normal
call charout, bold " ? " normal
pull moreopts
if moreopts='' then moreopts=def.!Moreopts

moreopts=a_replacestrg(moreopts,'*',def.!Moreopts,'ALL')
if strip(moreopts)=0 then moreopts=''
if moreopts<>'?' then say " Using options: " moreopts

if moreopts='?' then do
 call show_other_opts
 signal get_opts
end
moreopts=translate(moreopts,'&',' ')

/* now make a list */

list="font="||font||'&text='||message||'&height='||height||'&width='||width
list=list||'&back='||backgrnd||'&slide='||colorslide
if moreopts<>'' then list=list||'&'||moreopts

getgfile2:
Say
call charout,bold"Enter output file name (ENTER="def.!outgfile"):"normal
pull gfile2
if gfile2="" then gfile2=def.!outgfile
if gfile2="" then signal getgfile2
gfile0=stream(gfile2,'c','query exists')
if gfile0<>"" then do
    call charout,Gfile0 ' exists. Overwrite (Y/N)'
    pull anans
    if abbrev(strip(anans),'Y')<>1 then signal getgfile2
end /* do */
outgfile=gfile2

say
say " saving answers to GIF_TEXT.ANS "



aa='WIDTH='width||asep||'HEIGHT='height||asep||'FONT='font||asep
aa=aa||'BACKGRND='backgrnd||asep||'COLORSLIDE='colorslide||asep
aa=aa||'OUTGFILE='outgfile||asep||'MOREOPTS='Moreopts||asep
aa=aa||'MESSAGE='message||asep
foo=charout('GIF_TEXT.ANS',aa,1)
foo=stream('GIF_TEXT.ANS','c','close')

say " creating the image ..... "
return list  /* gfile2 is exposed */


ASKV:
SAY "Sorry, you made a goof.  Try again " sigl
exit


/*********/
show_other_opts:
say
say ' More commonly used options. p=parameter, n=0..9, nnn=0..255, vv=0.0 ... 1.0 '
say '   TIME_FMT: Time format. timefmt=p ; p=LNHSCM1 '
say '   DATE_FMT: Date format. datefmt=p ; p=NDEMBOSUW'
say ' BACK_SCALE: background display. back_scale=0/1 ; 1=scale, 0=tile '
say '        X_F: Size of frame (left and right), in pixels. x_f=n '
say '        Y_F: Size of frame (top and bottom), in pixels. y_f=n '
say '      X_SCA: Width scales:  X_SCA=vv+vv+vv (vv<1 = shrink, vv>1 enlarge'
say '      Y_SCA: Height scales: Y_SCA=vv+vv+vv'
say '      Y_VAL: Type of vertical alignment: Y_VAL=p ; p=TMB '
say '     LINE_J: Horizontal justifications (multi-line messages only)'
say ' These SLIDE_x options are only used when a color slide is specified'
say '    SLIDE_T: Threshold rules & parameter for color slides: slide_t=pnnn, p=PBC'
say '    SLIDE_V: Vertical mapping rule for color slides : T(ile),F(it),N(one)'
say '    SLIDE_H: Horizontal mapping rule for color slides (T(ile),F(it)'
say '    SLIDE_C: Center coordinates for color slide: slide_c=vv+vv'
say '   SLIDE_SI: Size of "user specified color slide" (# colors): slide_si=n'
say '   SLIDE_RE: Red color parameters for created slide: slide_red=vv+vv+vv"'
say '   SLIDE_GR: Green color parameters for created slide: slide_gr=vv+vv+vv "'
say '   SLIDE_BL: Blue color parameters for created slide: slide_bl=vv+vv+vv'
say '   SLIDE_PR: Probability parameters for using slide value: slide_pr=vv+vv+vv'
say ' Example: time_fmt=N  Y_SCA=0.5+1.2+2 x_F=2 y_f=2'
return 1


/*********/
/* show stuff in queue as a list */
show_dir_queue:procedure expose qlist.
parse arg lookfor
    ibs=0 ;mxlen=0
    if lookfor<>1 then
       nq=queued()
     else
        nq=qlist.0
    do ii=1 to nq
       if lookfor=1 then do
          aa=qlist.ii
          ii2=lastpos('\',aa) ; anam=substr(aa,ii2+1)
       end /* do */
       else do
          pull aa
          if pos(lookfor,aa)=0 then iterate
          parse var aa anam (lookfor) .
          if strip(anam)='.' | strip(anam)='..' then iterate
       end
       ibs=ibs+1
       blist.ibs=anam
       mxlen=max(length(anam),mxlen)
    end /* do */
arf=""
do il=1 to ibs
   anam=blist.il
   arf=arf||left(anam,mxlen+2)
   if length(arf)+mxlen+2>75  then do
        say arf
        arf=""
   end /* do */
end /* do */
if length(arf)>1 then say arf
say
return 1






 /* ------------------------------------------------------------------ */
 /* function: Check if ANSI is activated                               */
 /*                                                                    */
 /* call:     CheckAnsi                                                */
 /*                                                                    */
 /* where:    -                                                        */
 /*                                                                    */
 /* returns:  1 - ANSI support detected                                */
 /*           0 - no ANSI support available                            */
 /*          -1 - error detecting ansi                                 */
 /*                                                                    */
 /* note:     Tested with the German and the US version of OS/2 3.0    */
 /*                                                                    */
 /*                                                                    */
 CheckAnsi: PROCEDURE
   thisRC = -1

   trace off
                         /* install a local error handler              */
   SIGNAL ON ERROR Name InitAnsiEnd

   "@ANSI 2>NUL | rxqueue 2>NUL"

   thisRC = 0

   do while queued() <> 0
     queueLine = lineIN( "QUEUE:" )
     if pos( " on.", queueLine ) <> 0 | ,                       /* USA */
        pos( " (ON).", queueLine ) <> 0 then                    /* GER */
       thisRC = 1
   end /* do while queued() <> 0 */

 InitAnsiEnd:
 signal off error
 RETURN thisRC






a_replacestrg:

exactmatch=0
backward=0 ; doall=0

parse arg astring ,  target   , putme , type , exactmatch

type = translate(type)
if type="BACKWARD" then backward="YES"
if type="ALL" then doall="YES"

iat=1
joelen=length(target)
joelen2=length(putme)

doagain:                /* here if doall=yes */
 if exactmatch="YES" then do
    if   backward="YES" then
        joe= lastpos(target,astring)
    else
        joe= pos(target,astring,iat)
 end
 else do
   if   backward="YES" then
        joe= lastpos(translate(target),translate(astring))
    else
        joe= pos(translate(target),translate(astring),iat)
 end
 if joe=0 then
         return astring

 astring=delstr(astring,joe,joelen)
 if putme<>' ' then
    astring=insert(putme,astring,joe-1)

 if doall="YES" then do
     iat=joe+joelen2
     signal doagain
 end
/* else, all done */
 return astring




/* -------------------- */
/* get a yes or no , return 1 if yes */
yesno:procedure expose normal reverse bold
parse arg fooa , allopt,altans
if altans<>" " & words(altans)>1 then do
   w1=strip(word(altans,1))
   w2=strip(word(altans,2))
   a1=left(w1,1) ; a2=left(w2,1)
   a1a=substr(w1,2) ; a2a=substr(w2,2)
end
else do
    a1='Y' ; a1a='es'
    a2='N' ; a2a='o'
end  /* Do */
ayn='  '||bold||a1||normal||a1a||'\'||bold||a2||normal||a2a
if allopt=1 then  ayn=ayn||'\'||bold||'A'||normal||'ll'

do forever
 foo1=normal||reverse||fooa||normal||ayn
 call charout,  foo1 normal ':'
 pull anans
 if abbrev(anans,a1)=1 then return 1
 if abbrev(anans,a2)=1 then return 0
 if allopt=1 & abbrev(anans,'A')=1 then return 2
end

nocon:
if rc=-7 then return 0
exit 0

gpmprintf:procedure expose is_cgi
parse arg a1

if is_cgi=2 then do
  say a1
  return 1
end

if rxfuncquery('pmprintf')=0 then
    call pmprintf(a1)
return 0