dorl@vms.macc.wisc.edu (Michael Dorl - MACC) (07/29/88)
EndDo
End ! Srv_CopyTxt
Integer Function GetInteger (Buf, X, Lg)
Implicit None
C Parameter definitions
Character *(*) Buf
Integer *4 X
Integer *4 Lg
C Begin GetInteger
GetInteger = 0
C Skip leading blanks
Do While ((X .le. Lg) .and. (Buf(X:X) .eq. ' '))
X = X + 1
End Do
C Accumulate field
Do While
$ (
$ (X .le. Lg)
$ .and.
$ ((Buf(X:X) .ge. '0') .and. (Buf(X:X) .le. '9'))
$ )
GetInteger = 10 * GetInteger + IChar(Buf(X:X)) - IChar('0')
X = X + 1
EndDo
Return
End ! GetInteger
Subroutine GetField (Rsl, Src, Src_X, Src_Lg)
Implicit None
C Parameter definitions
Character *(*) Rsl ! Result
Character *(*) Src ! Source of data
Integer *4 Src_X ! Source index
Integer *4 Src_Lg ! Source length
C Local variables
Integer Rsl_X
Integer Rsl_Lg
C Begin GetField
Rsl = ' '
Rsl_X = 1
Rsl_Lg = Len(Rsl)
C Skip leading blanks
Do While
$ ((Src_X .le. Src_Lg) .and. (Src(Src_X:Src_X) .eq. ' '))
Src_X = Src_X + 1
EndDo
C Accumulate field
Do While
$ ((Src_X .le. Src_Lg) .and. (Src(Src_X:Src_X) .ne. ' '))
If (Rsl_X .le. Rsl_Lg) Then
Rsl(Rsl_X:Rsl_X) = Src(Src_X:Src_X)
Rsl_X = Rsl_X + 1
EndIf
Src_X = Src_X + 1
EndDo
Return
End ! GetField
Integer Function TrimLg (S)
Implicit None
Character *(*) S
TrimLg = Len(S)
Do While ((TrimLg .gt. 1) .and. (S(TrimLg:TrimLg) .eq. ' '))
TrimLg = TrimLg - 1
End Do
End
Subroutine ItoS (I,S,L)
C Description
C
C Converts integer I to a left justified space filled string S.
C Number of non blank charcaters returned in L
Implicit None
C Parameter definitions
Integer *4 I
Character *(*) S
Integer *4 L
C Local Definitions
Character *8 B
Integer *4 N
C Begin ItoS
Write (B, '(I8)') I
S = ' '
L = 0
Do N = 1,8
If (B(N:N) .ne. ' ') Then
If (L .lt. Len(S)) Then
L = L + 1
S(L:L) = B(N:N)
EndIf
EndIf
EndDo
End ! ItoS
Subroutine Get_Mail_Control
Include 'News.Def'
C External routines
External User_Open
Integer TrimLg
C Define the structure of the entries in the Sys$System:VMSMail.Dat file.
Structure /VMDDef/
Union
Map
Character *512 All
EndMap
Map
Character *31 UserName ! User Id
Integer *2 Flags ! Flags = self copy, edit, etc.
Integer *2 Mail ! New mail count
Integer *4 Spare(7)
Byte Spare1(2)
Byte DirLng ! Directory length
Byte FNmLng ! Full user name
Byte FwdLng ! Forward name length
Character *444 CMiscData ! Space for directory name,
! Full user name, and
! Forward name
EndMap
EndUnion
Integer *4 Lg ! Length of VMD record
Integer *4 DirX ! Directory index
Integer *4 FNmX ! Full name index
Integer *4 FwdX ! Forward index
End Structure ! VMDDef
C Length of fixed portion of VMS record
Parameter VMD_FxLng = 68
C values for VMD Flags
Parameter VMD_Flags_SendSelf = 1
Parameter VMD_Flags_ReplySelf = 2
Parameter VMD_Flags_NoPurge = 4
C Local definitions
Integer *4 Lg
Integer *4 Status
Record /VMDDef/ Vmd
Integer *4 X
C Begin Read_Mail_Control
Call UpPriv
Call User_Open_Init ('STATUS_OLD',0,0,0,0,0,0,0,0)
Call User_Open_Param ('EXEC_LOG',0,0,0,0,0,0,0,0,0)
Open
$ (
$ Unit = LU_VMSMail,
$ File = 'Sys$System:VMSMail.Dat',
$ Form = 'Formatted',
$ Status = 'Old',
$ Access = 'Keyed',
$ Shared,
$ UserOpen = User_Open,
$ IOStat = Status
$ )
Call DownPriv
UserPersonalName = ' '
UserMailDirectory = ' '
If (Status .ne. 0) Then
Return
EndIf
VMD.UserName = UserName
Call STR$UpCase (VMD.UserName, VMD.UserName)
Read
$ (
$ Unit = LU_VMSMail,
$ KeyId = 0,
$ KeyEq = VMD.UserName,
$ IOStat = Status,
$ Fmt = '(Q,A)'
$ )
$ VMD.Lg, VMD.All
If (Status .eq. 0) Then
Unlock (LU_VMSMail)
X = 1
If (VMD.FwdLng .ne. 0) Then
VMD.FwdX = X
Else
VMD.FwdX = 0
EndIf
X = X + VMD.FwdLng
If (VMD.FnmLng .ne. 0) Then
VMD.FnmX = X
UserPersonalName =
$ VMD.CMiscData(VMD.FnmX:VMD.FnmX+VMD.FnmLng-1)
Else
VMD.FnmX = 0
EndIf
X = X + VMD.FnmLng
If (VMD.DirLng .ne. 0) Then
VMD.DirX = X
Lg = TrimLg (UserDirectory) - 6
UserMailDirectory = UserDirectory(1:Lg) //
$ VMD.CMiscData(VMD.DirX+1:VMD.DirX+VMD.DirLng-1)
Else
UserMailDirectory = 'Sys$Login:'
VMD.DirX = 0
EndIf
EndIf
Close (LU_VMSMail)
End ! Read_Mail_Control
Integer Function TransLog (In, Out, Table)
Implicit None
Include '($PSLDef)'
Include '($LNMDef)'
C Parameter definitions
Character *(*) In ! name to be translated
Character *(*) Out ! resulting translated name
Integer *4 Table ! table 0 = User 'LNM$FILE_DEV'
! 1 = Exec 'LNM$SYSTEM_TABLE'
C Local definitions
Structure /ItmDef/
Integer *2 Length
Integer *2 Code
Integer *4 Address
Integer *4 ReturnLength
End Structure ! /ItmDef/
Integer *4 AcMode
Integer *4 Attr
Integer *4 InLg
Record /ItmDef/ ItmList(2)
Character *32 LogNameTable
Integer *4 LogNameTableLg
Integer *4 ResultLg
Integer TrimLg, Sys$TrnLnm
C Begin
Attr = LNM$M_Case_Blind
If (Table .eq. 0) Then
LogNameTable = 'LNM$FILE_DEV'
AcMode = PSL$C_User
Else If (Table .eq. 1) Then
LogNameTable = 'LNM$SYSTEM_TABLE'
AcMode = PSL$C_Exec
Else
Call Lib$Stop (%Val(0))
EndIf
LogNameTableLg = TrimLg (LogNameTable)
ItmList(1).Code = LNM$_String
ItmList(1).Length = Len(Out)
ItmList(1).Address = %Loc (Out)
ItmList(1).ReturnLength = %Loc(ResultLg)
ItmList(2).Code = 0
ItmList(2).Length = 0
Out = ' '
InLg = TrimLg (In)
TransLog = Sys$TrnLnm (Attr,
$ LogNameTable(1:LogNameTableLg),
$ In(1:InLg),
$ AcMode,
$ ItmList
$ )
End ! TransLog
Integer Function User_Edit (InFile, OutFile)
Implicit None
Include 'SMG.Def'
C Parameter Definition
Character *(*) InFile, OutFile
C External Routines
External Lib$Spawn
Integer Lib$Spawn
External SMG$Disable_Broadcast_Trapping
Integer SMG$Disable_Broadcast_Trapping
External SMG$Set_Broadcast_Trapping
Integer SMG$Set_Broadcast_Trapping
External SMG_Broadcast_AST
External TrimLg
Integer TrimLg
C Local Definitions
Character *128 Cmd
Integer Status
C Begin User_Edit
If (InFile .eq. ' ') Then
Cmd = '@MAIL$EDIT "" ' // OutFile
Else
Cmd = '@MAIL$EDIT ' //
$ Infile(1:TrimLg(InFile)) //
$ ' ' //
$ OutFile
EndIf
Status = SMG$Disable_Broadcast_Trapping (SMG_PBId)
User_Edit = Lib$Spawn
$ (
$ Cmd, ! Command String
$ , ! Input File
$ , ! Output File
$ , ! Flags
$ , ! Process Name
$ , ! Process Id
$ , ! Completion Status
$ , ! Completion EFN
$ , ! Completion ASTAdr
$ , ! Completion ASTArg
$ , ! Prompt
$ ! CLI
$ )
Status = SMG$Set_Broadcast_Trapping
$ (
$ SMG_PBId, ! Pasteboard-Id
$ SMG_Broadcast_AST, ! AST-Routine
$ ! AST-Argument
$ )
If (.not. Status) Then
Call Lib$Stop (%Val(Status))
EndIf
End ! User_Edit
Subroutine CacheHdr (G, Article, Subject, Subject_Lg)
Include 'News.Def'
C Parameter definition
Integer *4 G
Integer *4 Article
Character *(*) Subject
Integer *4 Subject_Lg
C External routines
Integer TrimLg
C Local definitions
Integer *4 NCache
Character *128 Cache_Subject (500)
Integer *4 Cache_Article (500)
Integer *4 I
C Begin CacheHdr
C Is the requested information in the cache?
If (NCache .gt. 0) Then
Do I = 1, NCache
If (Cache_Article(I) .eq. Article) Then
Subject = Cache_Subject(I)
Subject_Lg = TrimLg(Subject)
c Call SMG_All_Print ('hdr cache hit', '|')
Return
EndIf
EndDo
EndIf
C Requested information not cached, we have to read it.
Call XHdr (Article, 'subject', Subject, Subject_Lg)
If (NCache .lt. 500) Then
NCache = NCache + 1
I = NCache
Else
I = 1
EndIf
C Call SMG_All_Print ('Hdr cache no hit', '|')
Cache_Subject(I) = Subject(1:Subject_Lg)
Cache_Article(I) = Article
Return
C Begin CacheHdr_Init
Entry CacheHdr_Init (G)
NCache = 0
C Call SMG_All_Print ('Hdr cache init', '|')
Return
End ! CacheHdr
******** news_cld_install.com ********
$ Set command/Table=sys$common:[syslib]dcltables -
/Output=sys$common:[syslib]dcltables -
NewsDir:News.CLD
$ Dir/Date sys$common:[syslib]dcltables.exe
$ mcr install
sys$common:[syslib]dcltables.exe/replace
sys$common:[syslib]dcltables.exe/full
$
******** smg.def ********
C Define string descriptor, mainly used in places that need a
C zero length string
Structure /String_Def/
Integer *2 Length
Byte DType
Byte Class
Integer *4 Address
End Structure ! String_Def
C Screen management and terminal control information
Integer *4 SMGKeyDefId ! Define Key table id
Integer *4 SMGKeyBdId ! Virtual keyboard id
Integer *4 SMG_PBId ! Pasteboard Id
Integer *4 SMG_PBCols ! Pasteboard columns
Integer *4 SMG_PBRows ! Pastaboard rows
Logical SMG_Video ! .true. if video terminal
Logical SMG_Term ! .true. if interactive terminal
Integer *4 SMG_Line ! Screen line number
Character *132 PrintLine ! Work area for building print
! lines
C More information
Character *132 More_Input ! More response
Character *132 More_Hdg_One ! Heading line 1
Character *132 More_Hdg_Two ! Heading line 2
C Control C definition
Integer *4 TT_Chan
Integer *4 Control_C
C Common definition
Common /SMG/
$
$ SMGKeyDefId, SMGKeyBdId, SMG_PBId,
$ SMG_PBRows, SMG_PBCols, SMG_Video,
$ SMG_Term, SMG_Line,
$
$ PrintLine,
$
$ More_Input, More_Hdg_One, More_Hdg_Two,
$
$ Control_C, TT_Chan
******** smg_routines.for ********
Subroutine SMG_Initialize
Implicit None
Include 'SMG.Def'
Include '($RMSDef)'
Include '($SMGDef)/list'
C External definitions
Integer SMG$Create_Key_Table
Integer SMG$Create_PasteBoard
Integer SMG$Create_Virtual_Keyboard
Integer SMG$Define_Key
Integer SMG$Get_PasteBoard_Attributes
Integer SMG$Load_Key_Defs
Integer SMG$Set_Broadcast_Trapping
External SMG_Broadcast_Ast
External SMG$S_Pasteboard_Info_Block
External DC$_Term
C Local Definitions
Integer *4 Status
Record /SMGDef/ PB_Info
C Begin SMG_Initialize
Status = SMG$Create_PasteBoard
$ (SMG_PBId,,SMG_PBRows,SMG_PBCols,0)
If (.not. Status) Then
Call Lib$Stop(%Val(Status))
EndIf
If (SMG_PBCols .eq. 0) Then
SMG_PBCols = 132
EndIf
Status = SMG$Get_PasteBoard_Attributes
$ (SMG_PBId,PB_Info,%Loc(SMG$S_PasteBoard_Info_Block))
If (Status) Then
If (PB_Info.SMG$B_DevClass .eq. %Loc(DC$_Term)) Then
SMG_Term = .true.
Else
SMG_Term = .false.
EndIf
If ((PB_Info.SMG$B_DevClass .ne. %Loc(DC$_Term)) .or.
$ (PB_Info.SMG$B_SMG_DevType .eq. SMG$K_Unknown) .or.
$ (PB_Info.SMG$B_SMG_DevType .eq. SMG$K_HardCopy)
$ ) Then
SMG_Video = .false.
Else
SMG_Video = .true.
EndIf
Else
Call Lib$Stop(%Val(Status))
EndIf
Status = SMG$Create_Key_Table (SMGKeyDefId)
If (SMG_Term) Then
Status = SMG$Set_Broadcast_Trapping
$ (SMG_PBId, ! Pasteboard-Id
$ SMG_Broadcast_AST, ! AST-Routine
$ ! AST-Argument
$ )
If (.not. Status) Call Lib$Stop(%Val(Status))
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key PF1 ""/Echo/Set_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key PF2 "Help"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key PF2 "Dir/Folder"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key PF3 "Extract/Mail"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key PF3 "Extract"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key PF4 "Erase"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key PF4 "Select Mail"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP0 "Next"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP0 "Next/Edit"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP1 "Back"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP1 "Back/Edit"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP2 "Print"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP2 "Print/Print/Notify"' //
$ '/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP3 "Dir"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP3 "Dir/Start=999999"' //
$ '/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP4 "Current"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP4 "Current/Edit"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP5 "First"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP5 "First/Edit"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP6 "Last"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP6 "Last/Edit"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP7 "Send"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP7 "Send/Edit"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP8 "Reply"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP8 "Reply/Edit/Extract"' //
$ '/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP9 "Forward"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key KP9 "Forward/Edit"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key Enter "Select "/Echo/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key Minus "Read/New"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key Minus "Show New"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key Comma "Dir/New"/Echo/Terminate')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key Comma "Dir Mail"/Echo/Terminate/If_State=Gold')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key Period "File "/Echo')
Status = SMG$Define_Key (SMGKeyDefId,
$ 'Define/Key Period "Delete "/Echo/If_State=Gold')
Status = SMG$Load_Key_Defs
$ (
$ SMGKeyDefId, ! Table
$ 'MAIL$INIT', ! File
$ 'MAIL$INIT', ! Default file (so '.' is not used)
$ 1 ! File spec is logical name
$ )
If (.not. Status) Then
If (Status .ne. RMS$_FNF) Then
Call Lib$Signal (%Val(Status))
EndIf
EndIf
Call CLI$DCL_Parse ! Restore the parse state of the command
! that originally invoked the image.
! Load_Key_Def destroys the state and restores
! it if no error occurs; it does not restore
! it if an error does occur.
EndIf ! (SMG_Term)
Status = SMG$Create_Virtual_KeyBoard (SMGKeyBdId)
End ! SMG_Initialize
Subroutine SMG_Broadcast_AST
Implicit None
Include 'SMG.Def'
C Description
C AST Routine established by SMG_Initialize to trap and handle
C broadcast messages.
C External Routines and Symbols
External SMG$_No_MorMsg
Integer SMG$_No_MorMsg
External SMG$Get_Broadcast_Message
Integer SMG$Get_Broadcast_Message
External SMG$Cancel_Input
Integer SMG$Cancel_Input
External TrimLg
Integer TrimLg
C Local definitions
Integer Status
Character *132 Msg
Integer I
C Begin SMG_Broadcast_AST
Status = SMG$Cancel_Input (SMGKeyBdId)
Status = 1
Do While ((Status) .and. (Status .ne. %Loc(SMG$_No_MorMsg)))
Status = SMG$Get_Broadcast_Message (SMG_PBId, Msg)
If ((Status) .and. (Status .ne. %Loc(SMG$_No_MorMsg))) Then
Call SMG_Print (' ')
Call SMG_Print (Msg)
EndIf
EndDo
End ! SMG_Broadcast_AST
Subroutine SMG_Print_X (Buffer)
Implicit None
Include 'SMG.Def'
Include '($IODef)'
C Parameter definitions
Character *(*) Buffer
C External routines
Integer Sys$QIOW
C Local definitions
Integer *4 CC
Integer *4 L
Integer *4 IOSB(2)
Integer *4 Status
C Begin SMG_Print_X
L = Len(Buffer)
If (L .gt. SMG_PBCols) Then ! SMG_PBCols seems to be
L = SMG_PBCols ! defined even if
EndIf ! SMG_Video is .false.
If (.not. SMG_Term) Then
Print '(x,A)', Buffer(1:L)
Else
CC = '01000000'x
Status = Sys$QIOW
$ (
$ , ! efn
$ %Val(TT_Chan), ! channel
$ %Val(IO$_WriteVBlk), ! function
$ IOSB, ! IO status block
$ , ! astadr
$ , ! astprm
$ %Val(%Loc(Buffer)), ! p1 = buffer address
$ %Val(L), ! p2 = character count
$ , ! p3
$ %Val(CC), ! p4 = carriage control
$ , ! p5
$ ! p6
$ )
EndIf
SMG_Line = SMG_Line + 1
End ! SMG_Print_X
Integer Function SMG_More_Print (Text, Continuation)
Implicit None
Include 'SMG.Def'
C Description SMG_More_Print
C
C Breaks Text down into CR/LF separated pieces of maximum size
C SMG_PBCols. Calls more for each one. Second and subsequent
C pieces are prefaced by Continuation.
C
C Returns More status.
C
C Description SMG_Print
C
C Same as above but More is not called.
C
Integer SMG_Print
C Parameter Definitions
Character *(*) Text
Character *(*) Continuation
C External Routines
External More
Integer More
External TrimLg
Integer TrimLg
C Local Variables
Integer S ! Start of hunk in Text
Integer E ! End of hunk in Text
Integer L ! Length of Text
Integer LC ! Length of Continuation
Integer X ! Length of extra stuff for current hunk
Integer FF ! Location of form feeds
Character *512 Buffer
Character *2 CRLF
Integer CR
Integer NE
Logical More_Flag
C Begin SMG_More_Print
LC = Len(Continuation)
More_Flag = .true.
Goto 1
C Begin SMG_Print
Entry SMG_Print (Text)
LC = 0
More_Flag = .false.
C Begin common SMG_More_Print - SMG_Print
1 CRLF(1:1) = Char (13) ! <CR>
CRLF(2:2) = Char (10) ! <LF>
Call Expand_Tabs (Text, Buffer)
L = TrimLg (Buffer)
C Replace any form feed characters with blanks
FF = Index (Buffer,Char(12))
Do While (FF .ne. 0)
Buffer(FF:FF) = ' '
SMG_Line = 999
FF = Index (Buffer,Char(12))
End Do
S = 1
L = TrimLg(Buffer)
X = 0
SMG_More_Print = .true.
Do While (S .le. L)
C Attempt to print whatever is left
E = L
NE = E + 1
C But limit to SMG_PBCols
If ((E-S+1+X) .gt. SMG_PBCols) Then
E = S + SMG_PBCols - X - 1
NE = E + 1
EndIf
C But also take into account CR LF separated hunks
CR = Index (Buffer(S:L), CRLF)
If (CR .ne. 0) Then
CR = S + CR - 1
If (CR .eq. S) Then
E = S
NE = S + 2
Buffer (CR:CR+1) = ' '
Else If (CR .le. (E+1)) Then
E = CR - 1
NE = CR + 2
Else
! Don't care, this CR/LF outside of hunk
EndIf
EndIf
C Call more to see if this hunk fits on screen
If (More_Flag) Then
SMG_More_Print = More ()
If (.not. SMG_More_Print) Then
Return
EndIf
Else
SMG_More_Print = 1
EndIf
C Now, print this hunk
If (X .eq. 0) Then
Call SMG_Print_X (Buffer(S:E))
Else
Call SMG_Print_X (Continuation // Buffer(S:E))
End If
C New start is end of last line ignoring any trailing CR/LF
S = NE
C Length of extra stuff now includes continuation characters
X = LC
End Do
Return
End ! SMG_More_Print
Subroutine SMG_All_Print (Text, Continuation)
Implicit None
Include 'SMG.Def'
C Description
C
C Breaks Text down into SMG_PBCols sized pieces and prints same.
C Parameter Definitions
Character *(*) Text
Character *(*) Continuation
C External Routines
External TrimLg
Integer TrimLg
C Local Variables
Integer S ! Start of hunk in Text
Integer E ! End of hunk in Text
Integer L ! Length of Text
Integer LC ! Length of Continuation
Integer X ! Length of extrac stuff for current hunk
C Begin SMG_More_Print
S = 1
L = TrimLg(Text)
LC = Len(Continuation)
X = 0
Do While (S .le. L)
E = L
If (SMG_Video) Then
If ((E-S+1+X) .gt. SMG_PBCols) Then
E = S + SMG_PBCols - X - 1
EndIf
EndIf
If (X .eq. 0) Then
Call SMG_Print (Text(S:E))
Else
Call SMG_Print (Continuation // Text(S:E))
End If
S = E + 1
X = LC
End Do
End ! SMG_All_Print
Subroutine SMG_Erase
Implicit None
Include 'SMG.Def'
C Description:
C
C Erase the display if appropriate
C
C External Definitions:
External SMG$Erase_Pasteboard
Integer SMG$Erase_Pasteboard
C Local Definitions
Integer Status
C Begin SMG_Erase
If (SMG_Video) Then
Status = SMG$Erase_Pasteboard (SMG_PBId)
If (.not. Status) Then
Call Lib$Stop (%Val(Status))
End If
End If
SMG_Line = 1
End ! SMG_Erase
Integer Function More
Implicit None
Include 'SMG.Def'
C External Definitions
External SMG_Prompt
Integer SMG_Prompt
C Local Definitions
Integer Status
C Begin More
If (Control_C) Then
More = 0
Return
EndIf
More = 1
If (.not. SMG_Video) Then
Return
EndIf
If (SMG_Line .ge. (SMG_PBRows-4)) Then
SMG_Line = 0
Call SMG_Print_X (' ')
Call SMG_Print_X ('Press RETURN for more...')
Call SMG_Print_X (' ')
Status = SMG_Prompt
$ (More_Input, '> ', )
If ((More_Input .ne. ' ') .or. (.not. Status)) Then
More = 0
Else
Call More_Heading
EndIf
EndIf
Return
End ! More
Subroutine More_Heading
Implicit None
Include 'SMG.Def'
C Begin More_Heading
Call SMG_Erase
If (More_Hdg_One .ne. '@') Then
Call SMG_Print_X (More_Hdg_One)
EndIf
If (More_Hdg_Two .ne. '@') Then
Call SMG_Print_X (More_Hdg_Two)
EndIf
Call SMG_Print_X (' ')
End ! More_Heading
Subroutine Expand_Tabs (In, Out)
Implicit None
C Parameter Definitions
Character *(*) In, Out
C Local Definitions
Integer X_In, L_In, T_In, X_Out, L_Out, E_Out, L, T
Integer HT
Parameter (HT=9)
C Begin Expand_Tabs
X_In = 1
L_In = Len(In)
X_Out = 1
L_Out = Len(Out)
Do While (X_In .le. L_In)
C Find the next tab
T_In = Index (In(X_In:L_In), Char(HT))
If (T_In .ne. 0) Then
T_In = T_In + X_In - 1
C Tab, found move text before tab (if any) to output
L = T_In - X_In
If (L .gt. 0) Then
If (X_Out .le. L_Out) Then
E_Out = X_Out + L - 1
If (E_Out .gt. L_Out) Then
E_Out = L_Out
End If
Out(X_Out:E_Out) = In(X_In:X_In+L-1)
X_Out = X_Out + L
End If
End If
C Now advance to the next tab stop if not already there
T = 8 * ((X_Out-1)/8 + 1) + 1
L = T - X_Out
If (L .gt. 0) Then
If (X_Out .le. L_Out) Then
E_Out = X_Out + L - 1
If (E_Out .gt. L_Out) Then
E_Out = L_Out
End If
Out(X_Out:E_Out) = ' '
X_Out = X_Out + L
End If
End If
X_In = T_In + 1
Else
C No tab found, copy remaider of text to output
L = L_In - X_In + 1
If (L .gt. 0) Then
If (X_Out .le. L_Out) Then
E_Out = X_Out + L - 1
If (E_Out .gt. L_Out) Then
E_Out = L_Out
End If
Out(X_Out:E_Out) = In(X_In:L_In)
X_In = X_In + L
X_Out = X_Out + L
End If
End If
End If
End Do
C Blank fill rest of output
If (X_Out .le. L_Out) Then
Out(X_Out:L_Out) = ' '
End If
Return
End ! Expand_Tabs
Integer Function SMG_Prompt
$ (Get_String, Prompt_String, Get_Length)
Implicit None
Include 'SMG.Def'
Include '($SSDef)'
C Parameter Definitions
Character *(*) Get_String
Character *(*) Prompt_String
Integer *4 Get_Length
C External Definitions
External SMG$Read_Composed_Line
Integer SMG$Read_Composed_Line
External TrimLg
Integer TrimLg
C Local Definitions
Record /String_Def/ Init_Desc, Prompt_Desc
Character *128 Init_String
Integer *4 Get_String_Length
C Begin SMG_Prompt
Prompt_Desc.DType = 14
Prompt_Desc.Class = 1
Prompt_Desc.Address = %Loc(Prompt_String)
If (Prompt_String .eq. ' ') Then
Prompt_Desc.Length = 0
Else
Prompt_Desc.Length = Len(Prompt_String)
EndIf
Init_Desc.DType = 14
Init_Desc.Class = 1
Init_Desc.Address = %Loc(Init_String)
Init_Desc.Length = 0
1 SMG_Prompt = SMG$Read_Composed_Line
$ (
$ SMGKeyBdId, ! Keyboard Id
$ SMGKeyDefId, ! Key Table Id
$ Get_String, ! Received text
$ Prompt_Desc, ! Prompt text
$ Get_String_Length, ! received text length
$ , ! display id
$ , ! function key flags
$ Init_Desc ! ini string
$ )
SMG_Line = SMG_Line + 1
If ((SMG_Prompt .eq. SS$_Abort)
$ .or.
$ (SMG_Prompt .eq. SS$_Cancel)
$ ) Then
Init_String = Get_String
Init_Desc.Length = Get_String_Length
Goto 1
EndIf
If (Control_C) Then
Call SMG_Print (' ')
EndIf
If (%Loc(Get_Length) .ne. 0) Then
Get_Length = TrimLg(Get_String)
EndIf
End ! SMG_Prompt
Subroutine Ctrl_C
Implicit None
Include 'SMG.Def'
Include '($SysSrvNam)'
C Local Definitions
Integer *4 Status
C Begin Ctrl_C
Status = Sys$Assign ('TT', TT_Chan,,)
If (.not. Status) Then
Call Lib$Stop (%Val(Status))
EndIf
Call CtrlC_Enable
Control_C = 0
Return
End ! Ctrl_C
Subroutine CtrlC_Routine
Implicit None
Include 'SMG.Def'
C Begin CtrlC_Routine
Call CtrlC_Enable
Control_C = 1
Return
End ! CtrlC_Routine
Subroutine CtrlC_Enable
Implicit None
Include 'SMG.Def'
Include '($SysSrvNam)'
Include '($IODef)'
C External Definitions
External CtrlC_Routine
C Local Definitions
Integer *4 Status, Mode
C Begin CtrlC_Enable
Mode = IO$_SetMode .or. IO$M_CtrlCAst
Status = Sys$QIOW (,
$ %Val(TT_Chan),
$ %Val(Mode),
$ ,,,CtrlC_Routine,
$ ,%Val(3),,,
$ )
If (.not. Status) Then
C Ignore bad status so we can run from batch
c Call Lib$Stop (%Val(Status))
EndIf
Return
End ! CtrlC_Enable
******** tnews.cld ********
Define Verb TNews
Image "Dsk$User1:[MaccNet.Dorl.XXNews]News"
Qualifier Header Value(List)
Qualifier Mark Value(Type=$Rest_Of_Line)
******** up_dn_priv.for ********
Subroutine UpPriv
Implicit None
Include '($PrvDef)'
Include '($JPIDef)'
C External Definitions
External Sys$SetPrv
Integer Sys$SetPrv
External Sys$GetJpiW
Integer Sys$GetJpiW
External Lib$ExtV
Integer Lib$ExtV
C Local Definitions
Structure /ItmLstDef/
Integer *2 Buffer_Lg
Integer *2 Item_Code
Integer *4 Buffer_Addr
Integer *4 Return_Lg
End Structure ! ItmLstDef
Record /ItmLstDef/ ItemList(2)
Integer *4 Status, Privs(2), OldPrivs(2), ClrPrivs(2), PID
Logical PrivsAreUp
C Begin
Privs(1) = 0
Privs(2) = 0
Call Lib$InsV (1, Prv$V_Bypass, 1, Privs)
Call Lib$InsV (1, Prv$V_World, 1, Privs)
Call Lib$InsV (1, Prv$V_Oper, 1, Privs)
Status = Sys$SetPrv (%Val(1), Privs, %Val(0), OldPrivs)
If (.not. Status) Then
Call Lib$Stop (Status)
EndIf
ClrPrivs(1) = IAnd(Privs(1),.not. OldPrivs(1))
ClrPrivs(2) = IAnd(Privs(2),.not. OldPrivs(2))
If ((ClrPrivs(1) .ne. 0) .or. (ClrPrivs(2) .ne. 0)) Then
PrivsAreUp = .true.
Else
PrivsAreUp = .false.
EndIf
Return
Entry DownPriv
If (PrivsAreUp) Then
Status = Sys$SetPrv (%Val(0), ClrPrivs, %Val(0),)
EndIf
PrivsAreUp = .False.
Return
Entry SetUpPriv
ItemList(1).Item_Code = JPI$_ProcPriv
ItemList(1).Buffer_Lg = 8
ItemList(1).Buffer_Addr = %Loc(OldPrivs(1))
ItemList(1).Return_Lg = 0
ItemList(2).Item_Code = 0
ItemList(2).Buffer_Lg = 0
PID = 0
Status = Sys$GetJpiW
$ (, ! efn
$ PID, ! pidaddr
$ , ! prcnam
$ ItemList(1), ! itmlist
$ , ! iosb
$ , ! astadr
$ ! astprm
$ )
If (.not. Status) Then
Call Lib$Stop (%Val(Status))
EndIf
OldPrivs(1) = .not. OldPrivs(1) ! Clear all privileges
OldPrivs(2) = .not. OldPrivs(2) ! not in the process set.
Status = Sys$SetPrv (%Val(0), OldPrivs(1), %Val(0),)
If (.not. Status) Then
Call Lib$Stop (%Val(Status))
EndIf
%%end part d
Michael Dorl (608) 262-0466
dorl@vms.macc.wisc.edu
dorl@wiscmacc.bitnet