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