Fortran Wiki
ttee
!-----------------------------------------------------------------------------------------------------------------------------------
! this program needs the following file to crack the command line
! http://www.urbanjost.altervista.org/LIBRARY/libGPF/arguments/src/kracken.f90
!
include "kracken.f90"
!-----------------------------------------------------------------------------------------------------------------------------------
PROGRAM ttee
!
! "@(#) ttee(1) writes stdin to stdout and another file with an optional timestamp prefix"
!
USE m_kracken ! command line parameter cracking module
IMPLICIT NONE
integer , parameter :: clen=1024 !
CHARACTER(len=clen) :: string ! input line limit
CHARACTER :: prefix*20 ! prefix string
CHARACTER(LEN=8) :: date ! date for use in prefix
CHARACTER(LEN=10) :: time ! time for use in prefix
CHARACTER(LEN=10) :: access ! whether to append or overwrite output file
CHARACTER :: file*4096 ! output filenames
INTEGER :: outfile ! unit number for output file
INTEGER :: ios ! value of iostat on i/o errors
INTEGER :: iend1,iend2,ilen,ier
INTEGER :: len1,len2,len3 ! scratch variables for accumulating output filenames
CHARACTER(LEN=1024) :: strtok ! token function
CHARACTER(LEN=clen) :: token ! individual filenames
CHARACTER(LEN=4) :: delimiters ! token delimiters
INTEGER :: i10 ! counter for looping through file names
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! crack command line
CALL kracken('ttee','-o --output -a .F. --append .F. --timestamp none --help .F. --version .F.')
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! display version number if --version is present
IF(lget('ttee_-version'))THEN
WRITE(*,*)'ttee(1): version 1.0'
STOP
ENDIF
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! display help text and exit if --help is present
IF(lget('ttee_-help'))THEN
CALL usage()
ENDIF
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! decide whether to append to output file or overwrite it if -a or --append is present
access='sequential'
IF(lget('ttee_a'))THEN
access='append'
ENDIF
IF(lget('ttee_-append'))THEN
access='append'
ENDIF
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! open optional output file ... simply append FILENAME, -o FILENAME, -output FILENAME
file=' '
CALL retrev('ttee_oo', file, len1, ier) ! get any filename before any keywords
len2=min(clen,len1+2)
CALL retrev('ttee_o', file(len2:), len1, ier) ! append any filenames after -o keyword
len2=MIN(clen,len2+2+len1+2)
CALL retrev('ttee_-output', file(len2:), len1, ier) ! append any filenames after -output keyword
len3=LEN_TRIM(file) ! length of appended filenames
IF(len3.NE.0)THEN
outfile=9 ! initialize value used to get unit numbers for output files
! get list of filename separators
delimiters(1:1)=' ' ! space
delimiters(2:2)=CHAR(9) ! horizontal tab
delimiters(3:3)=CHAR(13) ! carriage return
delimiters(4:4)=CHAR(10) ! line feed (new line)
token = strtok(file, delimiters) ! get first filename from list
DO WHILE (token .NE. char(0))
outfile=outfile+1
OPEN(UNIT=outfile,FILE=token(:LEN_TRIM(token)),ACCESS=access,IOSTAT=ios,ERR=444)
token = strtok(CHAR(0), delimiters)
ENDDO
ELSE
outfile=-1 ! flag there is no output file specified
ENDIF
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! set prefix length to 0 or 20 depending on whether --timestamp value flags file to have timestamp prefix
iend1=20 ! number of prefix characters for stdout
iend2=20 ! number of prefix characters for outfiles
prefix=''! initialize prefix string
CALL retrev('ttee_-timestamp', file, ilen, ier)
IF(file(:ilen).EQ.'all')THEN
iend1=20
iend2=20
ELSEIF(ilen.EQ.0)THEN ! blank
iend1=20
iend2=20
ELSEIF(file(:ilen).EQ.'stdout')THEN
iend1=20
iend2=0
ELSEIF(file(:ilen).EQ.'output')THEN
iend1=0
iend2=20
ELSEIF(file(:ilen).EQ.'none')THEN
iend1=0
iend2=0
ELSE
CALL stderr('unknown timestamp value [stdout|all|output|none]')
STOP
ENDIF
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! loop reading stdin till end-of-file or error and write to stdout and output file with optional timestamp prefix
DO
READ(*,'(A)',ERR=111,END=999,IOSTAT=ios) string
ilen=LEN_TRIM(string)
IF(iend1.NE.0.OR.iend2.NE.0)THEN
CALL DATE_AND_TIME(DATE=date,TIME=time)
prefix(1:8)=date
prefix(10:19)=time
prefix(9:9)=' '
prefix(20:20)=':'
ENDIF
WRITE(*,'(A,A)',ERR=222,IOSTAT=ios) prefix(:iend1),string(:ilen)
IF(outfile.GE.0)THEN
DO I10=10,outfile
WRITE(I10,'(A,A)',ERR=333,IOSTAT=ios) prefix(:iend2),string(:ilen)
ENDDO
ENDIF
ENDDO
GOTO 999
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! some error messages
111 CONTINUE
! CALL stderr('error reading from stdin')
! WRITE(string,'(''IOSTAT='',i10)')ios
! CALL stderr(string)
GOTO 999
222 CONTINUE
CALL stderr('error writing to stout')
WRITE(string,'(''IOSTAT='',i10)')ios
CALL stderr(string)
GOTO 999
333 CONTINUE
CALL stderr('error writing to output')
WRITE(string,'(''IOSTAT='',i10)')ios
CALL stderr(string)
GOTO 999
444 CONTINUE
CALL stderr('error opening output')
WRITE(string,'(''IOSTAT='',i10)')ios
CALL stderr(string)
GOTO 999
999 CONTINUE
STOP
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
END PROGRAM
!-----------------------------------------------------------------------------------------------------------------------------------
SUBROUTINE stderr(message)
!
! "@(#) stderr writes a message to standard error using a standard f2003 method"
!
USE ISO_FORTRAN_ENV, ONLY : ERROR_UNIT ! access computing environment
CHARACTER(LEN=*) :: message
WRITE(ERROR_UNIT,'(a)')message(:len_trim(message)) ! write message to standard error
END SUBROUTINE stderr
!-----------------------------------------------------------------------------------------------------------------------------------
subroutine usage()
!
! "@(#) usage(3f90) writes program help to stdout and exits
!
write(*,*)'NAME'
write(*,*)' ttee(1)'
write(*,*)''
write(*,*)'SYNOPSIS'
write(*,*)' ttee [[-o|--output] filename] [-a|--append] [--timestamp FLAG] ...'
write(*,*)' [--help ] [--version]'
write(*,*)' ttee [OPTION]... [FILE]...'
write(*,*)''
write(*,*)'DESCRIPTION'
write(*,*)' Read from standard input and write to standard output and files'
write(*,*)' with an optional timestamp in front of each line.'
write(*,*)''
write(*,*)' -o --output'
write(*,*)' specify name of output log file'
write(*,*)''
write(*,*)' -a --append'
write(*,*)' append to the given FILEs, do not overwrite'
write(*,*)''
write(*,*)' --timestamp'
write(*,*)' which files to add the timestamp to. Default is "none"'
write(*,*)' Allowed values are stdout, output, all, none.'
write(*,*)''
write(*,*)' --help display this help and exit'
write(*,*)''
write(*,*)' --version'
write(*,*)' output version information and exit'
write(*,*)''
write(*,*)'EXAMPLES'
write(*,*)''
write(*,*)' program|ttee --output ttee.out --timestamp output|grep -i iteration'
write(*,*)''
write(*,*)'AUTHOR'
write(*,*)' John S. Urban'
write(*,*)''
write(*,*)'COPYRIGHT'
write(*,*)' Copyright (C) 2009 John S. Urban'
write(*,*)' This is free software: you are free to change and redistribute it.'
write(*,*)' There is NO WARRANTY, to the extent permitted by law.'
write(*,*)''
write(*,*)'LIMITS'
write(*,*)''
write(*,*)' Input line width maximum is 1024 characters.'
write(*,*)' Maximum length of output filenames is 4098, individual filename is 1024.'
write(*,*)' Minimum number of output files is probably at least 90; may be system dependent.'
write(*,*)''
write(*,*)''
write(*,*)'SEE ALSO'
write(*,*)' tee(1), cat(1), xargs(1)'
stop
end subroutine usage
!-----------------------------------------------------------------------------------------------------------------------------------
CHARACTER*1024 FUNCTION strtok (source_string, delimiters)
! @(#) Tokenize a string in a similar manner to C routine strtok(3c).
!
! DESCRIPTION:
! The `STRTOK' function is used to isolate sequential tokens
! in a null-terminated string, `*SOURCE_STRING'. These tokens are
! delimited in the string by at least one of the characters
! in `*DELIMITERS'. The first time that `STRTOK' is called,
! `*SOURCE_STRING' should be specified; subsequent calls,
! wishing to obtain further tokens from the same string, should
! pass a null pointer instead. The separator string, `*DELIMITERS',
! must be supplied each time and may change between calls.
!
! USAGE:
! First call STRTOK() with the string to tokenize as SOURCE_STRING,
! and the delimiter list used to tokenize SOURCE_STRING in DELIMITERS.
!
! then, if the returned value is not equal to CHAR(0), keep calling until it is
! with SOURCE_STRING set to CHAR(0).
!
! STRTOK will return a token on each call until the entire line is processed,
! which it signals by returning CHAR(0).
!
! Input: source_string = Source string to tokenize.
! delimiters = Delimiter string. Used to determine the beginning/end of each token in a string.
!
! Output: strtok()
!
! LIMITATIONS:
! can not be called with a different string until current string is totally processed, even from different procedures
! input string length limited to set size
! function returns fixed 1024 character length
! length of returned string not given
! PARAMETERS:
CHARACTER(len=*),intent(in) :: source_string
CHARACTER(len=*),intent(in) :: delimiters
! SAVED VALUES:
CHARACTER(len=1024),save :: saved_string
INTEGER,save :: isaved_start ! points to beginning of unprocessed data
INTEGER,save :: isource_len ! length of original input string
! LOCAL VALUES:
INTEGER :: ibegin ! beginning of token to return
INTEGER :: ifinish ! end of token to return
! initialize stored copy of input string and pointer into input string on first call
IF (source_string(1:1) .NE. CHAR(0)) THEN
isaved_start = 1 ! beginning of unprocessed data
saved_string = source_string ! save input string from first call in series
isource_len = LEN(saved_string) ! length of input string from first call
ENDIF
ibegin = isaved_start
DO
IF ( (ibegin .LE. isource_len) .AND. (INDEX(delimiters,saved_string(ibegin:ibegin)) .NE. 0)) THEN
ibegin = ibegin + 1
ELSE
EXIT
ENDIF
ENDDO
IF (ibegin .GT. isource_len) THEN
strtok = CHAR(0)
RETURN
ENDIF
ifinish = ibegin
DO
IF ((ifinish .LE. isource_len) .AND. (INDEX(delimiters,saved_string(ifinish:ifinish)) .EQ. 0)) THEN
ifinish = ifinish + 1
ELSE
EXIT
ENDIF
ENDDO
!strtok = "["//saved_string(ibegin:ifinish-1)//"]"
strtok = saved_string(ibegin:ifinish-1)
isaved_start = ifinish
END FUNCTION strtok
!----------------------------------------------------------------------------------------------------------------------------------- category: code