From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX"  7-AUG-1989 13:46
To:	MRGATE::"ARISIA::EVERHART"
Subj:	Printing tricks on a VAXstation.

Received: From KL.SRI.COM by CRVAX.SRI.COM with TCP; Sun,  6 AUG 89 01:48:07 PDT
Received: from twg.com by KL.SRI.COM with TCP; Sun, 6 Aug 89 01:31:59 PDT
Received: from TWG.COM by twg.com with SMTP ; Sun,  6 Aug 89 00:54:29 PDT
Received: from vax2.twg.com by Obelix.TWG.COM id aa25477; 6 Aug 89 0:54 PDT
Date: 6 Aug 89 00:35:00 PDT
From: WARNER LOSH <warner@TWG.COM>
Subject: Printing tricks on a VAXstation.
To: rse <rse@uxv.larc.nasa.gov>
Cc: info-vax <info-vax@kl.sri.com>
Message-Id:  <8908060054.aa25477@Obelix.TWG.COM>

Greetings!

I've gotten quite a few requests for this piece of code.  I wrote it while
I was at New Mexico Tech to help our users use the LaserJET printer that
was sitting next to the VAXstation.  This program creates a mailbox
called SCREEN_DUMP_MAILBOX.  You have to redirect your printer to
this mailbox (either by the setup menu or UIS$PRINT_DESTINATION) and
all monochrome screen dumps will be queued to SYS$PRINT.  It prints
at I believe 100 dots per inch.  This program kinda evolved from
one that did the same thing, except that the user had to run it
by hand after every screen dump.  It is a little slow on a VAXstation II,
but it gets the job done.  Run this program when your system boots
as system and all is set.  I think that all that it needs to have are
privs to create and open the mailbox, but I have never run it as someone
other than "SYSTEM" or my user account that had all privs at the time.

Please note this does not have any proprietary code in it.  I wrote it
before joining TWG.  Feel free to copy it and give it to other people to
your hearts content.  TWG assumes no responsibility for this code whatsoever!!

Feel free to contact me regarding this code.  I don't have too much free time
these days, but I'll try to answer whatever questions I can about this.

Warner Losh	Warner@twg.com	amdahl!twg-ap!warner	(415)962-7261
"And for those of you with digital watches, the barameter reads 29.05 inches.."
				-- Cpt Manilla just before landing at SFO
My views and spellings are my own.  Only the letters have been changed....

$! VAX/VMS archive file created by VMS_SHARE V06.10 7-FEB-1989.
$!
$! VMS_SHARE was written by James Gray (Gray:OSBUSouth@Xerox.COM) from
$! VMS_SHAR by Michael Bednarek (U3369429@ucsvc.dn.mu.oz.au).
$!
$! To unpack, simply save, concatinate all parts into one file and
$! execute (@) that file.
$!
$! This archive was created by user WARNER@HYDROVAX.NMT.EDU
$! on 28-JUL-1989 22:47:25.37.
$!
$! It contains the following 1 file:
$!        SCREEN_DUMPER.FOR
$!
$!============================================================================
$ SET SYMBOL/SCOPE=( NOLOCAL, NOGLOBAL )
$ VERSION = F$GETSYI( "VERSION" )
$ IF VERSION .GES "V4.4" THEN GOTO VERSION_OK
$ WRITE SYS$OUTPUT "You are running VMS ''VERSION'; ", -
    "VMS_SHARE V06.10 7-FEB-1989 requires VMS V4.4 or higher."
$ EXIT 44 ! SS$_ABORT
$VERSION_OK:
$ GOTO START
$!
$UNPACK_FILE:
$ WRITE SYS$OUTPUT "Creating ''FILE_IS'"
$ DEFINE/USER_MODE SYS$OUTPUT NL:
$ EDIT/TPU/COMMAND=SYS$INPUT/NODISPLAY/OUTPUT='FILE_IS'/NOSECTION -
    VMS_SHARE_DUMMY.DUMMY
b_part := CREATE_BUFFER( "{Part}", GET_INFO( COMMAND_LINE, "file_name" ) )
; s_file_spec := GET_INFO( COMMAND_LINE, "output_file" ); SET( OUTPUT_FILE
, b_part, s_file_spec ); b_errors := CREATE_BUFFER( "{Errors}" ); i_errors 
:= 0; pat_beg_1 := ANCHOR & "-+-+-+ Beginning"; pat_beg_2 := LINE_BEGIN 
& "+-+-+-+ Beginning"; pat_end := ANCHOR & "+-+-+-+-+ End"; POSITION
( BEGINNING_OF( b_part ) ); LOOP EXITIF SEARCH( SPAN( ' ' )@r_trail 
& LINE_END, FORWARD) = 0; POSITION( r_trail ); ERASE( r_trail ); ENDLOOP
; POSITION( BEGINNING_OF( b_part ) ); i_append_line := 0; LOOP EXITIF MARK
( NONE ) = END_OF( b_part ); s_x := ERASE_CHARACTER( 1 )
; IF s_x = '+' THEN r_skip := SEARCH( pat_beg_1, FORWARD, EXACT ); IF r_skip 
<> 0 THEN s_x := ''; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ERASE_LINE; ENDIF
; ENDIF; IF s_x = '-' THEN r_skip := SEARCH( pat_end, FORWARD, EXACT )
; IF r_skip <> 0 THEN s_x := ''; MOVE_HORIZONTAL( -CURRENT_OFFSET ); m_skip 
:= MARK( NONE ); r_skip := SEARCH( pat_beg_2, FORWARD, EXACT ); IF r_skip 
<> 0 THEN POSITION( END_OF( r_skip ) ); MOVE_HORIZONTAL( -CURRENT_OFFSET )
; MOVE_VERTICAL( 1 ); MOVE_HORIZONTAL( -1 ); ELSE POSITION( END_OF( b_part 
) ); ENDIF; ERASE( CREATE_RANGE( m_skip, MARK( NONE ), NONE ) ); ENDIF; ENDIF
; IF s_x = 'V' THEN s_x := ''; IF i_append_line <> 0 THEN APPEND_LINE
; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ENDIF; i_append_line := 1
; MOVE_VERTICAL( 1 ); ENDIF; IF s_x = 'X' THEN s_x := ''; IF i_append_line 
<> 0 THEN APPEND_LINE; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ENDIF
; i_append_line := 0; MOVE_VERTICAL( 1 ); ENDIF; IF s_x <> '' THEN i_errors 
:= i_errors + 1; s_text := CURRENT_LINE; POSITION( b_errors ); COPY_TEXT
( "The following line could not be unpacked properly:" ); SPLIT_LINE
; COPY_TEXT( s_x ); COPY_TEXT( s_text ); POSITION( b_part ); MOVE_VERTICAL
( 1 ); ENDIF; ENDLOOP; POSITION( BEGINNING_OF( b_part ) ); LOOP r_x := SEARCH
( "`", FORWARD, EXACT ); EXITIF r_x = 0; POSITION( r_x ); ERASE_CHARACTER
( 1 ); COPY_TEXT( ASCII( INT( ERASE_CHARACTER( 3 ) ) ) ); ENDLOOP
; IF i_errors = 0 THEN SET( NO_WRITE, b_errors, ON ); ELSE POSITION
( BEGINNING_OF( b_errors ) ); COPY_TEXT( FAO
( "The following !UL errors were detected while unpacking !AS", i_errors
, s_file_spec ) ); SPLIT_LINE; SET( OUTPUT_FILE, b_errors, "SYS$COMMAND" )
; ENDIF; EXIT; 
$ DELETE VMS_SHARE_DUMMY.DUMMY;*
$ CHECKSUM 'FILE_IS
$ WRITE SYS$OUTPUT " CHECKSUM ", -
  F$ELEMENT( CHECKSUM_IS .EQ. CHECKSUM$CHECKSUM, ",", "failed!!,passed." )
$ RETURN
$!
$START: 
$ FILE_IS = "SCREEN_DUMPER.FOR"
$ CHECKSUM_IS = 1409550364
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
XC
XC`009H p D u m p . F O R
XC
XC++
XC FACILITY:
XC`009Dump a part of the screen to an HP LaserJet
XC
XC ABSTRACT:
XC`009This program will convert a graphics dump for a SIXEL device,
XC`009such as an LA50, LA100, etc for use on the HP-Plotter.  It has
XC`009been modified so that it will work as a filter.  It now is always
XC`009running, waiting for input on a mailbox to be thrown at it.  See
XC`009SCREEN_DUMPER for more infomration.
XC
XC RESETICTIONS/BUGS:
XC`009Very little reasonablity checking is currently done.  No "scaling"
XC`009either.
XC
XC ENVIRONMENT:
XC`009VAX/VMS user mode.
XC
XC AUTHOR: M. Warner Losh, CREATION DATE: 27-Nov-1986
XC
XC--
X
XC`009%SBTTL 'Revision History'
XC++
XC
XC V2.0(3)-5`009By: M. Warner Losh`009On: 17-Aug-1988
XC`009`009Try to speed this guy up a bit.  Simple hack.
XC
XC V2.0(2)-4`009By: M. Warner Losh`009On: 29-Jul-1988
XC`009`009Fixed a small problem.  This program was leaving its temp
XC`009`009files around when it died.  This has been corrected by
XC`009`009only opening the output file when we need to.  We do this
XC`009`009after the READ in the main loop of DO_DUMP.  Since this
XC`009`009read is a blocking read, we don't have the problem anymore.
XC`009`009Unless the system crashes during a screen dump....
XC
XC V2.0(1)-3`009By: M. Warner Losh`009On: 28-Jul-1988
XC`009`009Fixed this so that ALL screendumps are now printed.  It
XC`009`009uses mailboxes.  It must be run BEFORE any screen dumps
XC`009`009can occur.  It sends the printout to SYS$PRINT.  You must
XC`009`009now set your PRINT DESTINATION to be "SCREEN_DUMP_MAILBOX".
XC
XC V1.0(1)-2`009By: M. Warner Losh`009On: 09-Sep-1987
XC`009`009Correct zero length line problem.
XC
XC X1.0(1)-1`009By: M. Warner Losh`009On: 27-Nov-1986
XC`009`009Create this module.
XC
XC--
X
X`009PROGRAM HPDUMP
X
X`009IMPLICIT NONE
X
X`009INTEGER SYS$CREMBX, SYS$DASSGN
X
X`009INTEGER Status
X`009INTEGER*2 Chan
X
XC+
XC Create the mailbox.  The print screen function has been redirected
XC to the logical SCREEN_DUMP_MAILBOX.  See page SYS-72 and SYS-109 of
XC the System Services Manual and Chapter Seven of the IO Reference
XC Manual, Part I for more information about these calls.
XC-
X`009Status = SYS$CREMBX (
X     $`009  %VAL (1),`009`009`009! prmflg
X     $`009  Chan,`009`009`009`009! chan
X     $`009  %VAL(1024),`009`009`009! maxmsg
X     $    %VAL(1024*10),`009`009! bufquo
X     $`009  ,`009`009`009`009! promsk
X     $`009  ,`009`009`009`009! acmode
X     $`009  'SCREEN_DUMP_MAILBOX')`009! lognam
X
X`009CALL Error_Check(Status)
X
XC+
XC Deassign the channel, since we won't be needing it.  We use FORTRAN to
XC open and close it later.  MUCH easier than the QIO crap.
XC-
X`009Status = SYS$DASSGN (%VAL(Chan))
X`009CALL Error_Check(Status)
X
XC+
XC Call the thing over and over.  Since I stole this from a program that
XC was already working, this seemed the easiest way to go.
XC-
X`009DO WHILE (.TRUE.)
X`009  CALL Do_Dump
X`009END DO
X`009END
X
V*****************************************************************************
X**
X*
X* DO_DUMP
X
X*     this routine does the actual dump.  It gets called repeatedly by the
X* mail program.  It is supposed to open the output file, read until the
X* end of the file is detected at the mailbox, then return for another
X* try at reading.
X*
X`009SUBROUTINE DO_DUMP
X
X`009IMPLICIT NONE
X
X`009PARAMETER
X     $`009  InLun = 10,`009`009`009! Input logical unit.
X     $`009  OutLun = 11,`009`009`009! Output logical unit.
X     $`009  Output_File_name = 'SYS$MANAGER:SCREEN_DUMP_TEMP_FILE.TMP'
X
X`009CHARACTER*2000 Chars`009`009! Characters read from file.
X`009LOGICAL*1 Bits(5000)`009`009! Bits to goto printer.
X`009INTEGER BitLen`009`009`009! Length of the bits.
X`009INTEGER I1`009`009`009! Loops, etc.
X`009INTEGER Start`009`009`009! Start of the String.
X`009CHARACTER ESC`009`009`009! CHAR(27)
X`009INTEGER Length`009`009  `009! Length of the string.
X`009LOGICAL Output_File_Opened`009! True when the file is open.
X
XC+
XC    Open the files.
XC-
X`009OPEN(UNIT=INLUN,NAME='SCREEN_DUMP_MAILBOX:',STATUS='OLD',READONLY,
X     $`009  CARRIAGECONTROL='NONE', FORM='FORMATTED')
XC+
XC    Read in the whole file and dump it to the LaserJet file.
XC-
X`009Output_File_Opened = .FALSE.
X`009DO WHILE (.TRUE.)
X`009  READ(InLun, 102, END=1000,ERR=1000) Length, Chars
X 102`009  FORMAT (Q,A)
X
X`009  IF (Chars(1:1) .EQ. Char(27)) THEN
X*  `009    IF (Chars(2:2) .EQ. '\') GO TO 1000
X`009    IF (Chars(2:2) .EQ. '\') GO TO 900
X`009    Start = 5
X`009  ELSE
X`009    Start = 1
X`009  END IF
X`009  CALL Convert_To_Binary(Chars(Start:Length), Bits, BitLen)
X`009  IF (.NOT. Output_File_Opened) THEN
X`009    OPEN(UNIT=OUTLUN,NAME=OUTPUT_FILE_NAME,STATUS='NEW',
X     $`009     CARRIAGECONTROL='NONE', FORM='FORMATTED',RECL=505)
X`009    Output_File_Opened = .TRUE.
XC+
XC    Set up the printer for Graphics stuff.
XC-
X`009    ESC = CHAR(27)
X `009    WRITE(OutLun, 101) ESC // 'E' // ESC // '*t100R' // ESC //`032
X     $`009      '&a0C' // ESC // '*r1A'
X 101`009    FORMAT(A)
X`009  END IF
X`009  DO I1 = 1, 6
X`009    CALL Dump_graphics(Bits, BitLen, I1, OutLUN)
X`009  END DO
X 900`009END DO
X
X 1000`009CONTINUE
X`009WRITE(OutLun, 101) ESC // '*rB'
X`009CLOSE (UNIT = OutLun)
X`009Output_File_Opened = .FALSE.
X`009CLOSE (UNIT = InLun)
X`009CALL PRINT_FILE (OUTPUT_FILE_NAME)
X`009RETURN
X`009END
X
V*****************************************************************************
X**
X
X`009SUBROUTINE Convert_To_Binary(
X     $`009  Chars,`009! C*(*) -->  Characters to LA50, etc.
X     $`009  Bits,`009`009! L(*)  <--  Bit map of string.
X     $    BitLen`009! I     <--  Number of bytes in "bits"
X     $`009  )
X
X`009IMPLICIT NONE
X
XC+
XC Formal parameters
XC-
X`009CHARACTER*(*) Chars
X`009LOGICAL*1 Bits(*)
X`009INTEGER BitLen
X`009INTEGER Num
XC+
XC Local variables
XC-
X`009INTEGER I1,I2
X`009CHARACTER Ch
X
XC+
XC  Subroutine code
XC-
X`009BitLen = 0
X`009I1 = 1
X`009DO WHILE (I1 .LE. Len(Chars))
X`009  Ch = Chars(I1:I1)
X`009  IF (Ch .EQ. '!') THEN
X`009    I1 = I1 + 1`009`009`009! Skip the '!'
X`009    Ch = Chars(I1:I1)
X`009    Num = 0
X`009    DO WHILE (Ch .GE. '0' .AND. Ch .LE. '9')
X`009      Num = Num * 10 + ICHAR(Ch) - ICHAR('0')
X`009      I1 = I1 + 1
X`009      Ch = Chars(I1:I1)
X`009    END DO
X`009    DO I2 = 1,Num
X`009      BitLen = BitLen + 1
X`009      Bits(BitLen) = ICHAR(Ch) - ICHAR('?')
X`009    END DO
X`009    I1 = I1 + 1`009`009`009! Move to next character
X`009  ELSE IF (Ch .eq. '-') THEN
X`009    GO TO 1000`009`009`009! End of line marker.
X`009  ELSE
X`009    BitLen = BitLen + 1
X`009    Bits(BitLen) = ICHAR(Ch) - ICHAR('?')
X`009    I1 = I1 + 1`009`009`009! Next character please.
X`009  END IF
X`009END DO
X 1000`009CONTINUE
X`009RETURN
X`009END
X
V*****************************************************************************
X**
X
X`009SUBROUTINE Dump_Graphics(
X     $`009  Bits,`009`009! --> L(*).  Bits to dump.
X     $`009  BitLen,`009! --> I.  Number of bits to dump
X     $`009  BitNum,`009! --> I.  Bit number to dump.
X     $`009  OutLun`009! --> I.  Output Logical unit.
X     $`009  )
X
X`009IMPLICIT NONE
X
X`009LOGICAL*1 Bits(*)
X`009INTEGER BitLen, BitNum, OutLun
XC+
XC   Local variables
XC-
X`009INTEGER*2 BUFFER(500)`009`009! Buffer for bits.
X`009INTEGER Offset`009`009`009! Offset of the byte to set.
X`009INTEGER Bit`009`009`009! Bit to set/clear.
X`009INTEGER Bit_Mask`009`009! Bit mask to check
X`009INTEGER Bytes`009`009`009! Bytes in BUFFER
X`009LOGICAL BitVal`009`009`009! Value of bit.
X`009INTEGER I1`009`009`009! Loops
X`009INTEGER Log_B`009`009`009! Log og the bytes.
X*A`009INTEGER I2
X*A  `009INTEGER The_Byte
X`009INTEGER Power_of_2(0:7)`009`009! Time savings
X`009DATA Power_of_2 /1,2,4,8,16,32,64,128/
XC+
XC   Subroutine code.
XC-
X
XC+
XC    initialize the buffer.
XC-
X`009Bytes = (BitLen + 7) / 8
X`009DO I1 = 1,Bytes
X`009  Buffer(I1) = 0
X`009END DO
X
XC+
XC    Step throught, xlating as we go.
XC-
X`009Bit_mask = Power_of_2(BitNum - 1)`009! Bit to test.
X`009DO I1 = 1, BitLen
X`009  Offset = (I1 - 1) / 8 + 1`009`009! Offset in  Buffer.
X`009  Bit = 7 - MOD(I1 - 1, 8)`009`009! Bit number to set/clear.
X`009  IF ((Bits(I1) .AND. Bit_Mask) .NE. 0) THEN
X`009    Buffer(Offset) = Buffer(offset) + power_of_2(Bit)
X`009  END IF
X`009END DO
X*A`009DO I1 = 0, Bytes - 1
X*A  `009  The_Byte = 0
X*A  `009  DO I2 = 0, 7
X*A  `009    IF ((Bits (I1 * 8 + I2) .AND. Bit_Mask) .NE. 0) THEN
X*A  `009      The_Byte = The_Byte + Power_Of_2(7 - I2)
X*A  `009    END IF
X*A  `009  END DO
X*A  `009  Buffer (I1 + 1) = The_Byte
X*A  `009END DO
X
X*C`009IF (Bytes .EQ. 0) THEN
X*C`009  Log_b = 1
X*C`009ELSE
X*C`009  Log_b = INT(Log10(Float(Bytes))) + 1
X*C`009END IF
X`009IF (Bytes .LT. 10) THEN
X`009  Log_b = 1
X`009ELSE IF (Bytes .LT. 100) THEN
X`009  Log_b = 2
X`009ELSE IF (Bytes .LT. 1000) THEN
X`009  Log_b = 3
X`009ELSE
X`009  Log_b = 4`009`009! Fake it...
X`009END IF
X`009WRITE (OutLun, 100) 27, Bytes,
X     $`009  (Buffer(I1), I1 = 1, Bytes)
X 100`009FORMAT (1A1,'*b', I<Log_b>, 'W', 500A1)
X*B 100`009FORMAT (1A1, '*b', I3.3, 'W', 500A1)
X`009RETURN
X`009END
X
V*****************************************************************************
X**
X
X`009SUBROUTINE Error_Check (Status)
X
X  `009IMPLICIT NONE
X
X`009INTEGER*2 Status
X
X`009IF (.NOT. Status) CALL LIB$STOP(%VAL(Status))
X
X`009RETURN
X`009END
X
V*****************************************************************************
X*
X*
X*`009PRINT_FILE
X*
X* This suboroutine will print the passed filename on SYS$PRINT with the
X* PASSALL and DELETE QUALIFIERS w/o spawning the command`032
X* "PRINT/PASSALL/DELETE FILENAME" to do it.  It uses the SYS$SndJbCW
X* system service.  More information about this call can be found in the
X* System Services Manual pages SYS-394 thru SYS-428.9  Yep, 45 pages.
X*
X
X`009SUBROUTINE PRINT_FILE (File_Name)
X
X`009IMPLICIT NONE
X
X`009CHARACTER *(*) File_Name
X
XC+
XC   Parameters and other symbol definitions.
XC-
X`009INCLUDE '($SJCDEF)'
XC+
XC   Local types and structures
XC-
X`009STRUCTURE /ITEM_LIST/
X`009  UNION
X`009    MAP
X`009`009INTEGER*2 Buffer_Length
X`009`009INTEGER*2 Item_Code
X`009`009INTEGER*4 Buffer_Address
X`009`009INTEGER*4 Return_Address
X`009    END MAP
X`009    MAP
X`009`009INTEGER*4 End_List
X`009    END MAP
X`009  END UNION
X`009END STRUCTURE
X
XC+
XC   External functions
XC-
X`009INTEGER SYS$SndJbCW
X
XC+
XC   Local variables
XC-
X`009RECORD /Item_List/ SndJbC_Item_List(20)
X`009INTEGER*2 IOSB (4)
X`009INTEGER Status
XC+
XC   Main Code
XC-
X`009SndJbC_Item_List(1).Buffer_Length = 9
X`009SndJbC_Item_List(1).Item_Code = SJC$_QUEUE
X`009SndJbC_Item_List(1).Buffer_Address = %LOC ('SYS$PRINT')
X`009SndJbC_Item_List(1).Return_Address = 0
X
X`009SndJbC_Item_List(2).Buffer_Length = LEN (File_Name)
X`009SndJbC_Item_List(2).Item_Code = SJC$_FILE_SPECIFICATION
X`009SndJbC_Item_List(2).Buffer_Address = %LOC (File_Name)
X`009SndJbC_Item_List(2).Return_Address = 0
X
X`009SndJbC_Item_List(3).Buffer_Length = 0
X`009SndJbC_Item_List(3).Item_Code = SJC$_PASSALL
X`009SndJbC_Item_List(3).Buffer_Address = 0
X`009SndJbC_Item_List(3).Return_Address = 0
X
X`009SndJbC_Item_List(4).Buffer_Length = 0
X`009SndJbC_Item_List(4).Item_Code = SJC$_DELETE_FILE
X`009SndJbC_Item_List(4).Buffer_Address = 0
X`009SndJbC_Item_List(4).Return_Address = 0
X
X`009SndJbC_Item_List(5).End_List = 0
X
X`009Status = SYS$SndJbCW (
X     $`009  ,`009`009    `009`009! efn
X     $`009  %VAL (SJC$_ENTER_FILE),`009! func
X     $`009  ,`009`009`009`009! Nullarg
X     $`009  SndJbC_Item_List,`009`009! Item list
X     $`009  IOSB,`009`009`009`009! IOSB
X     $`009  ,)`009`009`009`009! astadr, astprm
X
X`009CALL Error_Check (Status)
X`009CALL Error_Check (IOSB(1))
X
X`009RETURN
X`009END
$ GOSUB UNPACK_FILE
$ EXIT
-+-+-+-+-+ End of part 1 +-+-+-+-+-


