Clicky
Showing changes from revision #4 to #5:
(追記) Added (追記ここまで) | (削除) Removed (削除ここまで) | (削除) Chan (削除ここまで)(追記) ged (追記ここまで)
The SCCS what(1) command is not available by default on a number of Linux platforms. This is the what(1c) command re-implemented in Fortran. It adds the ability to format the output as an HTML table. It is a reduced version of what(1f) A number of modern Fortran features are used. Tested using GNU Fortran GCC 4.9.2. Requires the M_kracken MODULE for command-line parameter parsing. It is placed in the public domain. Feel free to alter this version to add useful extensions.
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
MODULE M_strings
!-----------------------------------------------------------------------------------------------------------------------------------
PRIVATE
PUBLIC split ! subroutine parses a string using specified delimiter characters and store tokens into an array
PUBLIC to_lower ! function converts string to lowercase
!-----------------------------------------------------------------------------------------------------------------------------------
CONTAINS
!-----------------------------------------------------------------------------------------------------------------------------------
SUBROUTINE split(input_line,array,delimiters,order,nulls)
!-----------------------------------------------------------------------------------------------------------------------------------
! @(#) parse a string using specified delimiter characters and store tokens into an array
!-----------------------------------------------------------------------------------------------------------------------------------
IMPLICIT NONE
INTRINSIC INDEX, MIN, PRESENT, LEN
!-----------------------------------------------------------------------------------------------------------------------------------
! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array.
! o by default adjacent delimiters in the input string do not create an empty string in the output array
! o no quoting of delimiters is supported
CHARACTER(LEN=*),INTENT(IN) :: input_line ! input string to tokenize
CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: delimiters ! list of delimiter characters
CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: order ! order of output array SEQUENTIAL|[REVERSE|RIGHT]
CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: nulls ! return strings composed of delimiters or not IGNORE|RETURN|IGNOREEND
CHARACTER(LEN=*),ALLOCATABLE,INTENT(OUT) :: array(:) ! output array of tokens
!-----------------------------------------------------------------------------------------------------------------------------------
INTEGER :: n ! max number of strings INPUT_LINE could split into if all delimiter
INTEGER,ALLOCATABLE :: ibegin(:) ! positions in input string where tokens start
INTEGER,ALLOCATABLE :: iterm(:) ! positions in input string where tokens end
CHARACTER(LEN=:),ALLOCATABLE :: dlim ! string containing delimiter characters
CHARACTER(LEN=:),ALLOCATABLE :: ordr ! string containing order keyword
CHARACTER(LEN=:),ALLOCATABLE :: nlls ! string containing order keyword
INTEGER :: ii,iiii ! loop parameters used to control print order
INTEGER :: icount ! number of tokens found
INTEGER :: ilen ! length of input string with trailing spaces trimmed
INTEGER :: i10,i20,i30 ! loop counters
INTEGER :: icol ! pointer into input string as it is being parsed
INTEGER :: idlim ! number of delimiter characters
INTEGER :: ifound ! where next delimiter character is found in remaining input string data
INTEGER :: inotnull ! count strings not composed of delimiters
INTEGER :: ireturn ! number of tokens returned
INTEGER :: imax ! length of longest token
!-----------------------------------------------------------------------------------------------------------------------------------
! decide on value for optional DELIMITERS parameter
IF (PRESENT(delimiters)) THEN ! optional delimiter list was present
IF(delimiters.NE.'')THEN ! if DELIMITERS was specified and not null use it
dlim=delimiters
ELSE ! DELIMITERS was specified on call as empty string
dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified
ENDIF
ELSE ! no delimiter value was specified
dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified
ENDIF
idlim=LEN(dlim) ! dlim a lot of blanks on some machines if dlim is a big string
!-----------------------------------------------------------------------------------------------------------------------------------
! decide on value for optional ORDER parameter
IF (PRESENT(order)) THEN ! allocate optional parameter value for specifying output order
ordr=to_lower(order)
ELSE ! no delimiter value was specified
ordr='sequential'
ENDIF
!-----------------------------------------------------------------------------------------------------------------------------------
IF (PRESENT(nulls)) THEN ! allocate optional parameter value for specifying output order
nlls=to_lower(nulls)
ELSE ! no delimiter value was specified
nlls='ignore'
ENDIF
!-----------------------------------------------------------------------------------------------------------------------------------
n=LEN(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter
ALLOCATE(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens
ALLOCATE(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens
ibegin(:)=1
iterm(:)=1
!-----------------------------------------------------------------------------------------------------------------------------------
ilen=LEN(input_line) ! ILEN is the column position of the last non-blank character
icount=0 ! how many tokens found
inotnull=0 ! how many tokens found not composed of delimiters
imax=0 ! length of longest token found
!-----------------------------------------------------------------------------------------------------------------------------------
SELECT CASE (ilen)
!-----------------------------------------------------------------------------------------------------------------------------------
CASE (:0) ! command was totally blank
!-----------------------------------------------------------------------------------------------------------------------------------
CASE DEFAULT ! there is at least one non-delimiter in INPUT_LINE if get here
icol=1 ! initialize pointer into input line
INFINITE: DO i30=1,ilen,1 ! store into each array element
ibegin(i30)=icol ! assume start new token on the character
IF(INDEX(dlim(1:idlim),input_line(icol:icol)).eq.0)THEN ! if current character is not a delimiter
iterm(i30)=ilen ! initially assume no more tokens
DO i10=1,idlim ! search for next delimiter
ifound=INDEX(input_line(ibegin(i30):ilen),dlim(i10:i10))
IF(ifound.GT.0)THEN
iterm(i30)=MIN(iterm(i30),ifound+ibegin(i30)-2)
ENDIF
ENDDO
icol=iterm(i30)+2 ! next place to look as found end of this token
inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters
ELSE ! character is a delimiter for a null string
iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning
icol=icol+1 ! advance pointer into input string
ENDIF
imax=max(imax,iterm(i30)-ibegin(i30)+1)
icount=i30 ! increment count of number of tokens found
IF(icol.GT.ilen)THEN ! text left
EXIT INFINITE
ENDIF
enddo INFINITE
!-----------------------------------------------------------------------------------------------------------------------------------
END SELECT
!-----------------------------------------------------------------------------------------------------------------------------------
SELECT CASE (trim(adjustl(nlls)))
CASE ('ignore','','ignoreend')
ireturn=inotnull
CASE DEFAULT
ireturn=icount
END SELECT
ALLOCATE(array(ireturn)) ! allocate the array to turn
!-----------------------------------------------------------------------------------------------------------------------------------
SELECT CASE (trim(adjustl(ordr))) ! decide which order to store tokens
CASE ('reverse','right') ; ii=ireturn; iiii=-1 ! last to first
CASE DEFAULT ; ii=1 ; iiii=1 ! first to last
END SELECT
!-----------------------------------------------------------------------------------------------------------------------------------
DO i20=1,icount ! fill the array with the tokens that were found
! write(*,*) i20,'@'//input_line(ibegin(i20):iterm(i20))//'@',ibegin(i20),iterm(i20)
IF(iterm(i20).LT.ibegin(i20))then
SELECT CASE (trim(adjustl(nlls)))
CASE ('ignore','','ignoreend')
CASE DEFAULT
array(ii)=' '
ii=ii+iiii
END SELECT
ELSE
array(ii)=input_line(ibegin(i20):iterm(i20))
ii=ii+iiii
ENDIF
ENDDO
!-----------------------------------------------------------------------------------------------------------------------------------
END SUBROUTINE split
!===================================================================================================================================
PURE FUNCTION to_lower(instr) result(outstr) ! @(#) function converts ASCII instr to lowercase
IMPLICIT NONE
!-----------------------------------------------------------------------------------------------------------------------------------
CHARACTER(LEN=*), INTENT(IN) :: instr ! mixed-case input string to change
CHARACTER(LEN=LEN(instr)) :: outstr ! lowercase output string to generate
!-----------------------------------------------------------------------------------------------------------------------------------
INTEGER :: i10 ! loop counter for stepping thru string
INTEGER :: ade ! ASCII Decimal Equivalent of current character
INTEGER,PARAMETER :: ade_a=IACHAR('A')
INTEGER,PARAMETER :: ade_z=IACHAR('Z')
!-----------------------------------------------------------------------------------------------------------------------------------
outstr=instr ! initially assume output string equals input string
!-----------------------------------------------------------------------------------------------------------------------------------
stepthru: DO i10=1,LEN(instr)
ade=IACHAR(instr(i10:i10)) ! convert letter to its value in ASCII collating sequence
IF(ade .GE. ade_a .AND. ade .LE. ade_z ) THEN ! if current letter is uppercase change it
outstr(i10:i10)=ACHAR(ade+32) ! change letter to lowercase
ENDIF
ENDDO stepthru
!-----------------------------------------------------------------------------------------------------------------------------------
END FUNCTION to_lower
!===================================================================================================================================
end MODULE M_strings
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
program wht
use M_kracken, only: kracken,lget,sget ! command argument parser
use M_strings, only: split, to_lower
USE ISO_FORTRAN_ENV, ONLY : ERROR_UNIT ! access computing environment
implicit none
character(len=4096),allocatable :: filename(:) ! array of filenames to read
logical :: stop_on_first = .false. ! switch to show only first string found or all
logical :: html = .false. ! switch to output as an HTML table
integer :: fd ! file descriptor for file currently being read
integer :: found = 0 ! command return status
integer :: ios ! hold I/O error flag
integer :: i ! loop counter
!-----------------------------------------------------------------------------------------------------------------------------------
! define command arguments and parse command line
call kracken('what','-s .false. -html .false.')
html=lget('what_html') ! get value of command line switch -html
stop_on_first=lget('what_s') ! if selected on command line, only display one string per file
call split(sget('what_oo'),filename) ! get filenames to scan from command line
if(size(filename).eq.0)then
filename=['-']
endif
!-----------------------------------------------------------------------------------------------------------------------------------
call sccs_id('"@(#)what(1) - find identification strings"') ! keep optimization from removing otherwise-unused variable
if(html)then ! if html output is selected print beginning of a simple HTML document
write(*,'(a)')'<html><head><title></title></head><body><table border="1">'
endif
FILES: do i=1,size(filename) ! step thru filenames to scan
if(filename(i).eq.'-'.or.filename(i).eq.'')then ! input file is standard input, but currently cannot be opened as a stream
fd=5
else ! open stream file
fd=10
open (unit=fd, file=trim(filename(i)), access='stream', status='old', iostat=ios)
if(ios.ne.0)then
WRITE(ERROR_UNIT,'(a)')'E-R-R-O-R: could not open '//trim(filename(i)) ! write message to standard error
cycle FILES
endif
endif
if(html)then
write(*,'(3a)',advance='no') '<tr><td><a href="',trim(filename(i)),'">'
write(*,'(a,"</a></td>")') trim(filename(i))
else
if(stop_on_first)then
write(*,'(a,":")',advance='no')trim(filename(i))
else
write(*,'(a,":")',advance='yes')trim(filename(i))
endif
endif
found = found + process_file()
close(unit=fd,iostat=ios)
enddo FILES
if(html)then
write(*,'(a)')'</table></body></html>'
endif
select case (found)
case(:0) ; stop 2
end select
!-----------------------------------------------------------------------------------------------------------------------------------
contains
!-----------------------------------------------------------------------------------------------------------------------------------
function process_file() RESULT (found)
! @(#)process_file - process the supplied file as a stream, and write output to stdout.
implicit none
integer,save :: ifound = 0
integer :: found
character :: c
integer,parameter :: got_nothing=0, got_at=1, got_open=2,got_hash=3,got_all=4
integer :: status
integer :: ios ! hold I/O error flag
status = got_nothing
if(html)then
write(*,'(a)')'<td>'
endif
look_for_prefix: DO
select case(fd)
case(5); read(fd,'(a1)',iostat=ios,advance='no') c
if( ios.ne.0 .and. (.not.is_iostat_eor(ios)) )exit look_for_prefix
case default; read(fd,iostat=ios) c
if(ios.ne.0) exit look_for_prefix
end select
select case(c)
case('@')
status = got_at
case('(')
if (status == got_at) status = got_open
case('#')
if (status == got_open) status = got_hash
case(')')
if (status == got_hash) then ! got all of prefix so start outputting characters
status=got_all
! Output tab and it ident string followed by a new line.
ifound = ifound + 1
write(*,'(a)',advance='no')achar(9) ! output tab before string being found
OUTPUT: do
read(fd,iostat=ios) c
if(ios.ne.0)then
exit LOOK_FOR_PREFIX
endif
select case(c)
case('"','>',(削除) '\\' (削除ここまで)(追記) '\' (追記ここまで))
exit OUTPUT
case(:achar(31),achar(127):) ! end on non-printable character
exit OUTPUT
case default
write(*,'(a)',advance='no')c
end select
enddo OUTPUT
if(html)then
write (*, '(a)')'<br/>' ! newline
else
write(*,*) ! newline
endif
if (stop_on_first)then
exit LOOK_FOR_PREFIX
endif
endif
case default
status = got_nothing ! start looking for new prefix
end select
enddo LOOK_FOR_PREFIX
if(html)then
write(*,'(a)')'</td>'
endif
found=ifound
end function process_file
!-----------------------------------------------------------------------------------------------------------------------------------
subroutine sccs_id(string)
implicit none
character(len=*),intent(in) :: string
character(len=10) :: debug
call GET_ENVIRONMENT_VARIABLE('DEBUG',debug)
if(index(debug,':WHAT:').ne.0)then
write(*,'(a)')trim(string)
endif
end subroutine sccs_id
!-----------------------------------------------------------------------------------------------------------------------------------
end program wht
!-----------------------------------------------------------------------------------------------------------------------------------