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