| !------------------------------------------------------------------------
! SCR - a program for copying an image on some VT240 terminal to a file.
!
! Inspired by: Yosi Karl Oct.1987
! Written by: Shlomo Wygodny Oct.1987
! Modified by: Nitsan Duvdevani Nov.1987
!
! The following program was originally written by some customers. It copies
! a VT240 screen image into a file. The file can then be printed on the
! laser, re-displayed on the screen, merged into other files (e.g., word-
! -processor output), mailed to others, etc.
!
! It is actually a "local print screen" into a file.
!
! The screen image may contain anything you want: graphics, text, things drawn
! in local mode, whatever. The "compressed-print/expanded-print/rotated-print"
! options of the terminal Setup (see: graphics) may be used.
!
! Before run, define the following logical names:
!
! SCR$INPUT = device to be copied [default: SYS$INPUT]
! SCR$OUTPUT = output file name [default: SCR.IMAGE]
!
! And the following should be defined as "x,y" in PIXELS:
!
! SCR$OFFSET = offset of image on output device [default: 50,0]
! SCR$ORIGIN = origin of screen rectangle to be recorded [default: 0,0]
! SCR$EXTENT = right-bottom of same rectangle [default: 799,479]
!------------------------------------------------------------------------
program scr
implicit none
include '($iodef)'
include '($ttdef)'
parameter ESC = char('033'o)
parameter start_regis = ESC // '[?2i' // ESC // 'P1p'
parameter stop_regis = ESC // '\'
integer buf_size
parameter (buf_size = 256)
character*(buf_size) buf
character*40 input_name /'SCR$INPUT'/
character*40 output_name /'SCR$OUTPUT'/
character*40 offset /'SCR$OFFSET'/
character*40 origin /'SCR$ORIGIN'/
character*40 extent /'SCR$EXTENT'/
integer*4 status,input_chan,iofunc,sys$assign,sys$qiow,bufnum
logical read_flag /.true./
structure /sense_status_block/
integer*2 iostat
byte transmit,receive,crfill,lffill,parity,zero
end structure
record /sense_status_block/ sensesb
structure /io_status_block/
integer*2 iostat,term_offset,terminator,term_size
end structure
record /io_status_block/ iosb
structure /characteristics/
byte class,type
integer*2 width
union
map
integer*2 basic
end map
map
byte length(4)
end map
end union
integer*4 extended
end structure
record /characteristics/ saved_term,changed_term
! Handle logical names:
! ---------------------
call check_lnm (input_name,'SYS$INPUT',.false.)
call check_lnm (output_name,'SCR.IMAGE',.false.)
call check_lnm (offset,'50,0',.true.)
call check_lnm (origin,'0,0',.true.)
call check_lnm (extent,'799,479',.true.)
! Open things:
! ------------
status = sys$assign (input_name(1:index(input_name,' ')-1),
* input_chan,,)
if (.not.status) call lib$stop (%val(status))
open (unit=16, file=input_name(1:index(input_name,' ')-1),
* status='OLD', carriagecontrol='NONE', err=888)
open (unit=17, file=output_name(1:index(output_name,' ')-1),
* status='NEW', form='UNFORMATTED', carriagecontrol='LIST',
* recordtype='VARIABLE', err=888)
! Set term/hostsync:
! ------------------
status = sys$qiow (,%val(input_chan),%val(io$_sensemode),sensesb,,,
* saved_term,%val(12),,,,)
if (.not.status) call lib$stop (%val(status))
if (.not.sensesb.iostat) call lib$stop (%val(sensesb.iostat))
changed_term = saved_term
changed_term.basic = ibset(changed_term.basic,tt$v_hostsync)
status = sys$qiow (,%val(input_chan),%val(io$_setmode),sensesb,,,
* changed_term,%val(12),,,,)
if (.not.status) call lib$stop (%val(status))
if (.not.sensesb.iostat) call lib$stop (%val(sensesb.iostat))
! Poll the terminal for the image:
! --------------------------------
write (16,1000) start_regis,
* origin(1:index(origin,' ')-1),
* extent(1:index(extent,' ')-1),
* offset(1:index(offset,' ')-1),
* stop_regis
1000 format (a,'S(H[',a,'][',a,'](P[',a,']))',a)
! Read the image transmitted:
! ---------------------------
bufnum = 1
iofunc = io$_readvblk .or. io$m_noecho .or. io$m_escape
do while (read_flag)
status = sys$qiow (,%val(input_chan),%val(iofunc),iosb,,,
* %ref(buf),%val(buf_size),,,,)
if (.not.status) call lib$stop (%val(status))
if (.not.iosb.iostat) call lib$stop (%val(iosb.iostat))
if (bufnum.gt.3 .and. iosb.terminator.ne.0) read_flag = .false.
write (17) buf(1:iosb.term_offset+iosb.term_size)
bufnum = bufnum + 1
enddo
! Reset terminal:
! ---------------
status = sys$qiow (,%val(input_chan),%val(io$_setmode),sensesb,,,
* saved_term,%val(12),,,,)
if (.not.status) call lib$stop (%val(status))
if (.not.sensesb.iostat) call lib$stop (%val(sensesb.iostat))
! Close things:
! -------------
call sys$dassgn (%val(input_chan))
close (unit=16)
close (unit=17)
call exit
! Error exit:
! -----------
888 call lib$put_output ('%SCR-E-FILERR, file access error')
end
subroutine check_lnm (in_str,default,translate)
!-------------------------------------------------------------------------
! This subroutine checks whether "in_str" is defined.
! If not, it's replaced by the "default" string.
! If yes and "translate" requested, it's replaced by the equivalence name.
!-------------------------------------------------------------------------
implicit none
include '($lnmdef)'
include '($ssdef)'
character*(*) in_str,default
logical translate
character*40 out_str
integer*4 status,sys$trnlnm,return_length
structure /itmlst/
integer*2 buffer_length
integer*2 item_code
integer*4 buffer_address
integer*4 return_length_address
integer*4 terminator
end structure
record /itmlst/ item_list
out_str = ' '
return_length = 0
item_list.buffer_length = 40
item_list.item_code = lnm$_string
item_list.buffer_address = %loc(out_str)
item_list.return_length_address = %loc(return_length)
item_list.terminator = 0
status = sys$trnlnm (lnm$m_case_blind,'lnm$file_dev',
* in_str(1:index(in_str,' ')-1),,item_list)
if (status.eq.ss$_nolognam) then
in_str = default
else if (.not.status) then
call lib$stop (%val(status))
else
if (translate) in_str = out_str(1:return_length)
endif
end
|