Fortran Wiki
what

what(1f) command

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
!-----------------------------------------------------------------------------------------------------------------------------------

category: code