1module m_sax_reader 2 3private 4 5integer, parameter, public :: BUFFER_NOT_CONNECTED = -2048 6integer, private, parameter :: MAXLENGTH = 1024 7 8type, public :: file_buffer_t 9private 10 logical :: connected 11 logical :: eof 12 integer :: lun 13 character(len=50) :: filename 14 integer :: counter 15 character(len=MAXLENGTH) :: buffer 16 integer :: line 17 integer :: col 18 integer :: pos 19 integer :: nchars 20 logical :: debug 21 ! 22 integer :: io_eor 23 integer :: io_eof 24end type file_buffer_t 25 26public :: get_character, sync_file 27public :: line, column, nchars_processed 28public :: open_file, close_file_buffer, rewind_file, mark_eof_file 29public :: eof_file 30 31private :: fill_buffer 32private :: get_unit, find_eor_eof 33 34CONTAINS 35 36!----------------------------------------- 37! 38subroutine open_file(fname,fb,iostat,record_size,verbose) 39character(len=*), intent(in) :: fname 40type(file_buffer_t), intent(out) :: fb 41integer, intent(out) :: iostat 42integer, intent(in), optional :: record_size 43logical, intent(in), optional :: verbose 44 45iostat = 0 46 47call find_eor_eof(fb%io_eor,fb%io_eof) 48 49fb%connected = .false. 50 51call get_unit(fb%lun,iostat) 52if (iostat /= 0) then 53 if (fb%debug) print *, "Cannot get unit" 54 return 55endif 56 57if (present(verbose)) then 58 fb%debug = verbose 59else 60 fb%debug = .false. 61endif 62 63if (present(record_size)) then 64 open(unit=fb%lun,file=fname,form="formatted",status="old", & 65 action="read",position="rewind",recl=record_size,iostat=iostat) 66else 67 open(unit=fb%lun,file=fname,form="formatted",status="old", & 68 action="read",position="rewind",recl=65536,iostat=iostat) 69endif 70if (iostat /= 0) then 71 if (fb%debug) print *, "Cannot open file ", trim(fname), " iostat: ", iostat 72 return 73endif 74 75fb%connected = .true. 76fb%counter = 0 77fb%eof = .false. 78fb%line = 1 79fb%col = 0 80fb%filename = fname 81fb%pos = 0 82fb%nchars = 0 83fb%buffer = "" 84 85end subroutine open_file 86 87!------------------------------------------------- 88subroutine rewind_file(fb) 89type(file_buffer_t), intent(inout) :: fb 90 91fb%eof = .false. 92fb%counter = 0 93fb%line = 1 94fb%col = 0 95fb%pos = 0 96fb%nchars = 0 97fb%buffer = "" 98 99rewind(unit=fb%lun) 100 101end subroutine rewind_file 102!----------------------------------------- 103subroutine mark_eof_file(fb) 104type(file_buffer_t), intent(inout) :: fb 105 106fb%eof = .true. 107 108end subroutine mark_eof_file 109 110!----------------------------------------- 111subroutine close_file_buffer(fb) 112type(file_buffer_t), intent(inout) :: fb 113 114if (fb%connected) then 115 close(unit=fb%lun) 116 fb%connected = .false. 117endif 118 119end subroutine close_file_buffer 120 121!------------------------------------------------- 122function eof_file(fb) result (res) 123type(file_buffer_t), intent(in) :: fb 124logical :: res 125 126res = fb%eof 127 128end function eof_file 129!----------------------------------------- 130!----------------------------------------- 131! New version, able to cope with arbitrarily long lines 132! (still need to specify a big enough record_size if necessary) 133! 134subroutine fill_buffer(fb,iostat) 135type(file_buffer_t), intent(inout) :: fb 136integer, intent(out) :: iostat 137! 138! 139character(len=81) :: str ! 80 seems like a good compromise? 140 ! (1 extra for added newline, see below) 141integer :: len=-1 ! initialization for buggy compilers 142! 143read(unit=fb%lun,iostat=iostat,advance="no",size=len,fmt="(a80)") str 144 145if (iostat == fb%io_eof) then 146 147 ! End of file 148 if (fb%debug) print *, "End of file." 149 return 150 151else if (iostat > 0) then 152 153 ! Hard i/o error 154 if (fb%debug) print *, "Hard i/o error. iostat:", iostat 155 RETURN 156 157else 158! 159 if (fb%debug) then 160 print *, "Buffer: len, iostat", len, iostat 161 print *, trim(str) 162 endif 163 164 fb%pos = 0 165 166 if (iostat == 0) then 167 168 ! Normal read, with more stuff left on the line 169 ! 170 fb%buffer = str(1:len) 171 fb%nchars = len 172 173 else ! (end of record) 174 ! 175 ! End of record. We mark it with an LF, whatever it is the native marker. 176 ! 177!! fb%buffer = str(1:len) // char(10) 178 fb%buffer = str(1:len) !! Avoid allocation of string 179 len = len + 1 !! by compiler 180 fb%buffer(len:len) = char(10) 181 fb%nchars = len 182 iostat = 0 183 endif 184 185endif 186 187end subroutine fill_buffer 188 189!--------------------------------------------------------------- 190subroutine get_character(fb,c,iostat) 191character(len=1), intent(out) :: c 192type(file_buffer_t), intent(inout) :: fb 193integer, intent(out) :: iostat 194 195character(len=1) :: c_next 196 197if (.not. fb%connected) then 198 iostat = BUFFER_NOT_CONNECTED 199 return 200endif 201 202if (fb%pos >= fb%nchars) then 203 call fill_buffer(fb,iostat) 204 if (iostat /= 0) return 205endif 206fb%pos = fb%pos + 1 207c = fb%buffer(fb%pos:fb%pos) 208fb%counter = fb%counter + 1 ! Raw counter 209fb%col = fb%col + 1 210! 211! Deal with end-of-line handling on the processor... 212! 213if (c == char(10)) then 214 ! Our own marker for end of line 215 fb%line = fb%line + 1 216 fb%col = 0 217endif 218if (c == char(13)) then 219 c_next = fb%buffer(fb%pos+1:fb%pos+1) 220 if (c_next == char(10)) then 221 ! 222 ! Found CRLF. We replace it by LF, as per specs. 223 c = c_next 224 fb%pos = fb%pos + 1 225 if (fb%debug) print *, "-/-> Removed CR before LF in get_character" 226 else 227 ! Replace single CR by LF 228 c = char(10) 229 if (fb%debug) print *, "-/-> Changed CR to LF in get_character -- line++" 230 ! 231 endif 232 ! In both cases we increase the line counter and reset the column 233 ! 234 fb%line = fb%line + 1 235 fb%col = 0 236endif 237 238iostat = 0 239 240end subroutine get_character 241 242!---------------------------------------------------- 243!---------------------------------------------------- 244! Error Location functions 245! 246function line(fb) result (ll) 247type(file_buffer_t), intent(in) :: fb 248integer :: ll 249 250ll = fb%line 251end function line 252 253!---------------------------------------------------- 254function column(fb) result (col) 255type(file_buffer_t), intent(in) :: fb 256integer :: col 257 258col = fb%col 259end function column 260!---------------------------------------------------- 261!---------------------------------------------------- 262function nchars_processed(fb) result (nc) 263type(file_buffer_t), intent(in) :: fb 264integer :: nc 265 266nc = fb%counter 267end function nchars_processed 268!---------------------------------------------------- 269 270subroutine sync_file(fb,iostat) 271type(file_buffer_t), intent(inout) :: fb 272integer, intent(out) :: iostat 273! 274! Repositions the file so that it matches with 275! the stored file_buffer information 276! 277integer :: target_counter 278character(len=1) :: c 279 280target_counter = fb%counter 281call rewind_file(fb) 282iostat = 0 283do 284 if (fb%counter == target_counter) exit 285 call get_character(fb,c,iostat) 286 if (iostat /= 0) return 287enddo 288 289end subroutine sync_file 290 291! ---------------------------------------------------------------------- 292subroutine get_unit(lun,iostat) 293 294! Get an available Fortran unit number 295 296integer, intent(out) :: lun 297integer, intent(out) :: iostat 298 299integer :: i 300logical :: unit_used 301 302do i = 10, 99 303 lun = i 304 inquire(unit=lun,opened=unit_used) 305 if (.not. unit_used) then 306 iostat = 0 307 return 308 endif 309enddo 310iostat = -1 311lun = -1 312end subroutine get_unit 313! ---------------------------------------------------------------------- 314 315subroutine find_eor_eof(io_eor,io_eof) 316! 317! Determines the values of the iostat values for End of File and 318! End of Record (in non-advancing I/O) 319! 320integer, intent(out) :: io_eor 321integer, intent(out) :: io_eof 322 323integer :: lun, iostat 324character(len=1) :: c 325 326call get_unit(lun,iostat) 327 328if (iostat /= 0) stop "Out of unit numbers" 329 330open(unit=lun,status="scratch",form="formatted", & 331 action="readwrite",position="rewind",iostat=iostat) 332if (iostat /= 0) stop "Cannot open test file" 333 334write(unit=lun,fmt=*) "a" 335write(unit=lun,fmt=*) "b" 336 337rewind(unit=lun) 338 339io_eor = 0 340do 341 read(unit=lun,fmt="(a1)",advance="NO",iostat=io_eor) c 342 if (io_eor /= 0) exit 343enddo 344 345io_eof = 0 346do 347 read(unit=lun,fmt=*,iostat=io_eof) 348 if (io_eof /= 0) exit 349enddo 350 351close(unit=lun,status="delete") 352 353end subroutine find_eor_eof 354 355end module m_sax_reader 356