1module m_buffer
2
3!
4! At this point we use a fixed-size buffer.
5! Note however that buffer overflows will only be
6! triggered by overly long *unbroken* pcdata values, or
7! by overly long attribute values. Hopefully
8! element or attribute names are "short enough".
9! There is code in m_fsm to avoid buffer overflows
10! caused by pcdata with whitespace.
11!
12! In a forthcoming implementation it could be made dynamical...
13!
14integer, parameter, public   :: MAX_BUFF_SIZE  = 1024
15integer, parameter, private  :: BUFF_SIZE_WARNING  = 900
16
17!
18
19type, public  :: buffer_t
20private
21      integer                       :: size
22      character(len=MAX_BUFF_SIZE)  :: str
23end type buffer_t
24
25public :: add_to_buffer
26public :: print_buffer, str, len
27public :: operator (.equal.)
28public :: buffer_nearly_full, reset_buffer, init_buffer
29public :: buffer_to_character
30
31!----------------------------------------------------------------
32interface add_to_buffer
33      module procedure add_str_to_buffer
34end interface
35private :: add_char_to_buffer, add_str_to_buffer
36
37interface operator (.equal.)
38      module procedure compare_buffers, compare_buffer_str, &
39             compare_str_buffer
40end interface
41private :: compare_buffers, compare_buffer_str, compare_str_buffer
42
43interface str
44      module procedure buffer_to_str
45end interface
46private :: buffer_to_str
47
48interface len
49   module procedure buffer_length
50end interface
51private :: buffer_length
52
53CONTAINS
54!==================================================================
55
56!----------------------------------------------------------------
57function compare_buffers(a,b) result(equal)     ! .equal. generic
58type(buffer_t), intent(in)  :: a
59type(buffer_t), intent(in)  :: b
60logical                     :: equal
61
62equal = ((a%size == b%size) .and. (a%str(1:a%size) == b%str(1:b%size)))
63
64end function compare_buffers
65
66!----------------------------------------------------------------
67function compare_buffer_str(buffer,str) result(equal) ! .equal. generic
68type(buffer_t), intent(in)   :: buffer
69character(len=*), intent(in) :: str
70logical                      :: equal
71
72equal = (buffer%str(1:buffer%size) == trim(str))
73
74end function compare_buffer_str
75
76!----------------------------------------------------------------
77function compare_str_buffer(str,buffer) result(equal) ! .equal. generic
78character(len=*), intent(in) :: str
79type(buffer_t), intent(in)   :: buffer
80logical                     :: equal
81
82equal = (buffer%str(1:buffer%size) == trim(str))
83
84end function compare_str_buffer
85
86!----------------------------------------------------------------
87subroutine add_char_to_buffer(c,buffer)
88character(len=1), intent(in)   :: c
89type(buffer_t), intent(inout)  :: buffer
90
91integer   :: n
92buffer%size = buffer%size + 1
93n = buffer%size
94
95if (n> MAX_BUFF_SIZE) then
96!!  RETURN
97!
98!  It will only affect long comments and sgml declarations
99   STOP "Buffer overflow: long unbroken string of pcdata or attribute value..."
100endif
101
102buffer%str(n:n) = c
103end subroutine add_char_to_buffer
104
105!----------------------------------------------------------------
106subroutine add_str_to_buffer(s,buffer)
107character(len=*), intent(in)   :: s
108type(buffer_t), intent(inout)  :: buffer
109
110integer   :: n, len_s, last_pos
111
112len_s = len(s)
113last_pos = buffer%size
114buffer%size = buffer%size + len_s
115n = buffer%size
116
117if (n> MAX_BUFF_SIZE) then
118!!  RETURN
119!
120!  It will only affect long comments and sgml declarations
121  STOP "Buffer overflow: long unbroken string of pcdata or attribute value..."
122endif
123
124buffer%str(last_pos+1:n) = s
125end subroutine add_str_to_buffer
126
127!----------------------------------------------------------------
128subroutine init_buffer(buffer)
129type(buffer_t), intent(inout)  :: buffer
130
131buffer%size = 0
132buffer%str=""               ! To avoid "undefined" status
133
134end subroutine init_buffer
135!----------------------------------------------------------------
136subroutine reset_buffer(buffer)
137type(buffer_t), intent(inout)  :: buffer
138  buffer%size = 0
139end subroutine reset_buffer
140!----------------------------------------------------------------
141subroutine print_buffer(buffer)
142type(buffer_t), intent(in)  :: buffer
143
144integer :: i
145
146do i = 1, buffer%size
147      write(unit=6,fmt="(a1)",advance="no") buffer%str(i:i)
148enddo
149
150end subroutine print_buffer
151!----------------------------------------------------------------
152! This is better... but could it lead to memory leaks?
153!
154function buffer_to_str(buffer) result(str)
155type(buffer_t), intent(in)          :: buffer
156character(len=buffer%size)          :: str
157
158str = buffer%str(1:buffer%size)
159end function buffer_to_str
160
161!----------------------------------------------------------------
162!
163subroutine buffer_to_character(buffer,str)
164type(buffer_t), intent(in)          :: buffer
165character(len=*), intent(out)       :: str
166
167str = buffer%str(1:buffer%size)
168end subroutine buffer_to_character
169
170!----------------------------------------------------------------
171function buffer_nearly_full(buffer) result(warn)
172type(buffer_t), intent(in)          :: buffer
173logical                             :: warn
174
175warn = buffer%size > BUFF_SIZE_WARNING
176
177end function buffer_nearly_full
178
179!----------------------------------------------------------------
180function buffer_length(buffer) result(length)
181type(buffer_t), intent(in)          :: buffer
182integer                             :: length
183
184length = buffer%size
185
186end function buffer_length
187
188
189end module m_buffer
190
191
192
193
194
195
196
197