module sia_stat use iso_c_binding use sia_const private public :: modestring type, public :: statbuf ! C struct stat and associated routines integer(kind=c_int64_t) :: dev=-1,ino=-1,mode=-1,nlink=0,uid=-1,gid=-1,& rdev=0,size=0,blksize=0,blocks=0,atime=-1,mtime=-1,ctime=-1 ! Real versions of timestamps, with fractional part if needed: real(kind=c_double) :: artime=0, mrtime=0, crtime=0 logical :: valid=.false. contains procedure :: stat=>statbuf_stat procedure :: lstat=>statbuf_lstat procedure :: clear=>statbuf_clear procedure :: isreg=>statbuf_isreg procedure :: islnk=>statbuf_islnk procedure :: isdir=>statbuf_isdir procedure :: perms=>statbuf_permissions procedure :: strkind=>statbuf_strkind end type statbuf interface subroutine c_stat_lstat(filename,n,statptr,ierr, & dev,ino,mode,nlink,uid,gid,rdev,size,blksize,blocks,& atime,mtime,ctime,artime,mrtime,crtime) bind(c) use iso_c_binding character(kind=c_char) :: filename(*) type(c_ptr) :: statptr integer(kind=c_int64_t),value,intent(in) :: n ! = 1 for lstat, = 0 for stat integer(kind=c_int64_t),intent(out) :: ierr real(kind=c_double), intent(out) :: artime,mrtime,crtime integer(kind=c_int64_t),intent(out) :: & dev,ino,mode,nlink,uid,gid,rdev,size,blksize,blocks,& atime,mtime,ctime end subroutine c_stat_lstat end interface contains subroutine modestring(mode,string) use iso_c_binding, only: c_int64_t integer(kind=c_int64_t), intent(in) :: mode character(len=10), intent(out) :: string string='----------' if(0/=iand(mode,S_IRUSR)) string(2:2)='r' if(0/=iand(mode,S_IRGRP)) string(5:5)='r' if(0/=iand(mode,S_IROTH)) string(8:8)='r' if(0/=iand(mode,S_IWUSR)) string(3:3)='w' if(0/=iand(mode,S_IWGRP)) string(6:6)='w' if(0/=iand(mode,S_IWOTH)) string(9:9)='w' if(0/=iand(mode,S_IXUSR)) then if(0/=iand(mode,S_ISUID)) then string(4:4)='s' else string(4:4)='x' endif elseif(0/=iand(mode,S_ISUID)) then string(4:4)='S' endif if(0/=iand(mode,S_IXGRP)) then if(0/=iand(mode,S_ISGID)) then string(7:7)='s' else string(7:7)='x' endif elseif(0/=iand(mode,S_ISGID)) then string(7:7)='S' endif if(0/=iand(mode,S_IXOTH)) then if(0/=iand(mode,S_ISVTX)) then string(10:10)='t' else string(10:10)='x' endif elseif(0/=iand(mode,S_ISVTX)) then string(10:10)='T' endif if(S_IFDIR==iand(mode,S_IFMT)) then string(1:1)='d' ! Directory elseif(S_IFLNK==iand(mode,S_IFMT)) then string(1:1)='l' ! Symbolic link elseif(S_IFCHR==iand(mode,S_IFMT)) then string(1:1)='c' ! Character device elseif(S_IFBLK==iand(mode,S_IFMT)) then string(1:1)='b' ! Block device elseif(S_IFREG==iand(mode,S_IFMT)) then string(1:1)='-' ! Regular file elseif(S_IFIFO==iand(mode,S_IFMT)) then string(1:1)='p' ! FIFO (named pipe) elseif(S_IFSOCK==iand(mode,S_IFMT)) then string(1:1)='s' ! Socket else string(1:1)='?' ! Some other file type endif end subroutine modestring function statbuf_strkind(s) result(k) character(len=16) :: k character(len=16), parameter :: & invalid_str="stat failed ",& regular_str="regular file ",& link_str ="symbolic link ",& socket_str ="socket ",& char_str ="character device",& block_str ="block device ",& fifo_str ="fifo/named pipe ",& dir_str ="directory ",& unknown_str="unknown type " class(statbuf), intent(in) :: s if(.not.s%valid) then ; k=invalid_str elseif(iand(s%mode,S_IFMT)==S_IFSOCK) then ; k=socket_str elseif(iand(s%mode,S_IFMT)==S_IFDIR) then ; k=dir_str elseif(iand(s%mode,S_IFMT)==S_IFLNK) then ; k=link_str elseif(iand(s%mode,S_IFMT)==S_IFREG) then ; k=regular_str elseif(iand(s%mode,S_IFMT)==S_IFBLK) then ; k=block_str elseif(iand(s%mode,S_IFMT)==S_IFCHR) then ; k=char_str elseif(iand(s%mode,S_IFMT)==S_IFIFO) then ; k=fifo_str else ; k=unknown_str endif end function statbuf_strkind function statbuf_permissions(s) use iso_c_binding, only: c_null_char,c_char,c_int64_t class(statbuf), intent(inout) :: s integer(kind=c_int64_t) :: statbuf_permissions statbuf_permissions=iand(s%mode,4095) end function statbuf_permissions logical function statbuf_isreg(s) class(statbuf), intent(inout) :: s statbuf_isreg = s%valid .and. 0/=iand(s%mode,S_IFREG) end function statbuf_isreg logical function statbuf_isdir(s) class(statbuf), intent(inout) :: s statbuf_isdir = s%valid .and. 0/=iand(s%mode,S_IFDIR) end function statbuf_isdir logical function statbuf_islnk(s) class(statbuf), intent(inout) :: s statbuf_islnk = s%valid .and. 0/=iand(s%mode,S_IFLNK) end function statbuf_islnk logical function statbuf_stat(s,filename,statptr) use iso_c_binding class(statbuf), intent(inout) :: s character(len=*) :: filename character(kind=c_char) :: filename0(len(filename)+1) integer(kind=c_int64_t) :: ierr,n,i type(c_ptr), intent(out), optional :: statptr type(c_ptr) :: istatptr do i=1,len(filename) filename0(i)=filename(i:i) enddo filename0(i)=c_null_char istatptr=c_null_ptr n=0 if(present(statptr)) n=n+2 call c_stat_lstat(filename0,n,istatptr,ierr,& s%dev,s%ino,s%mode,s%nlink,s%uid,s%gid,s%rdev,s%size,s%blksize,& s%blocks,s%atime,s%mtime,s%ctime,s%artime,s%mrtime,s%crtime) if(present(statptr)) statptr=istatptr s%valid = ierr==0 statbuf_stat=s%valid end function statbuf_stat logical function statbuf_lstat(s,filename,lstatptr) use iso_c_binding class(statbuf), intent(inout) :: s character(len=*) :: filename character(kind=c_char) :: filename0(len(filename)+1) integer(kind=c_int64_t) :: ierr,n,i type(c_ptr), intent(out), optional :: lstatptr type(c_ptr) :: istatptr 18 format(A,': f stat len=',I0) !print 18,filename,len(filename) do i=1,len(filename) filename0(i)=filename(i:i) enddo filename0(i)=c_null_char istatptr=c_null_ptr n=1 if(present(lstatptr)) n=n+2 call c_stat_lstat(filename0,n,istatptr,ierr,& s%dev,s%ino,s%mode,s%nlink,s%uid,s%gid,s%rdev,s%size,s%blksize,& s%blocks,s%atime,s%mtime,s%ctime,s%artime,s%mrtime,s%crtime) if(present(lstatptr)) lstatptr=istatptr s%valid = ierr==0 statbuf_lstat=s%valid 13 format(A,': lstat failed: ',I0) 23 format(A,': lstat success: ',I0) if(statbuf_lstat) then !print 23,filename,ierr else !print 13,filename,ierr endif end function statbuf_lstat subroutine statbuf_clear(s) class(statbuf), intent(out) :: s integer :: ierr s%valid=.false. s%dev=-1 s%ino=-1 s%mode=0 s%nlink=0 s%uid=-1 s%gid=-1 s%rdev=0 s%size=0 s%blksize=0 s%blocks=0 s%atime=-1 s%mtime=-1 s%ctime=-1 end subroutine statbuf_clear end module sia_stat