read_record_header Subroutine

private subroutine read_record_header(unit, expected_tag, swapped, count, ok, err)

Read a record header, check the type tag, and bounds check the announced payload against the real length of the file.

Comparing the payload with inquire(size=) before allocating is what turns a truncated or corrupt file into a clean ERROR_IO instead of a wild allocation followed by a short read.

Arguments

Type IntentOptional Attributes Name
integer(kind=default_int), intent(in) :: unit
integer(kind=int32), intent(in) :: expected_tag
logical, intent(in) :: swapped
integer(kind=int64), intent(out) :: count
logical, intent(out) :: ok
type(error_t), intent(inout) :: err

Calls

proc~~read_record_header~~CallsGraph proc~read_record_header read_record_header interface~to_char to_char proc~read_record_header->interface~to_char proc~bswap_int32 bswap_int32 proc~read_record_header->proc~bswap_int32 proc~bswap_int64 bswap_int64 proc~read_record_header->proc~bswap_int64 proc~check_io check_io proc~read_record_header->proc~check_io proc~element_bytes element_bytes proc~read_record_header->proc~element_bytes proc~error_set error_t%error_set proc~read_record_header->proc~error_set proc~to_char_char to_char_char interface~to_char->proc~to_char_char proc~to_char_dp to_char_dp interface~to_char->proc~to_char_dp proc~to_char_int32 to_char_int32 interface~to_char->proc~to_char_int32 proc~to_char_int64 to_char_int64 interface~to_char->proc~to_char_int64 proc~to_char_logical to_char_logical interface~to_char->proc~to_char_logical proc~to_char_matrix_dp to_char_matrix_dp interface~to_char->proc~to_char_matrix_dp proc~to_char_matrix_int32 to_char_matrix_int32 interface~to_char->proc~to_char_matrix_int32 proc~to_char_matrix_int64 to_char_matrix_int64 interface~to_char->proc~to_char_matrix_int64 proc~to_char_matrix_sp to_char_matrix_sp interface~to_char->proc~to_char_matrix_sp proc~to_char_sp to_char_sp interface~to_char->proc~to_char_sp proc~to_char_vector_dp to_char_vector_dp interface~to_char->proc~to_char_vector_dp proc~to_char_vector_int32 to_char_vector_int32 interface~to_char->proc~to_char_vector_int32 proc~to_char_vector_int64 to_char_vector_int64 interface~to_char->proc~to_char_vector_int64 proc~to_char_vector_sp to_char_vector_sp interface~to_char->proc~to_char_vector_sp proc~check_io->interface~to_char proc~check_io->proc~error_set

Called by

proc~~read_record_header~~CalledByGraph proc~read_record_header read_record_header proc~read_char_record read_char_record proc~read_char_record->proc~read_record_header proc~read_int32_array read_int32_array proc~read_int32_array->proc~read_record_header proc~read_int64_array read_int64_array proc~read_int64_array->proc~read_record_header proc~read_real_dp_array read_real_dp_array proc~read_real_dp_array->proc~read_record_header proc~read_real_sp_array read_real_sp_array proc~read_real_sp_array->proc~read_record_header interface~read_array read_array interface~read_array->proc~read_char_record interface~read_array->proc~read_int32_array interface~read_array->proc~read_int64_array interface~read_array->proc~read_real_dp_array interface~read_array->proc~read_real_sp_array proc~soa_read_int32_field soa_read_int32_field proc~soa_read_int32_field->interface~read_array proc~soa_read_int64_field soa_read_int64_field proc~soa_read_int64_field->interface~read_array proc~soa_read_logical_field soa_read_logical_field proc~soa_read_logical_field->interface~read_array proc~soa_read_prologue soa_read_prologue proc~soa_read_prologue->interface~read_array proc~soa_read_real_dp_field soa_read_real_dp_field proc~soa_read_real_dp_field->interface~read_array proc~soa_read_real_sp_field soa_read_real_sp_field proc~soa_read_real_sp_field->interface~read_array interface~soa_read_field soa_read_field interface~soa_read_field->proc~soa_read_int32_field interface~soa_read_field->proc~soa_read_int64_field interface~soa_read_field->proc~soa_read_logical_field interface~soa_read_field->proc~soa_read_real_dp_field interface~soa_read_field->proc~soa_read_real_sp_field proc~particle_soa_deserialize particle_soa_t%particle_soa_deserialize proc~particle_soa_deserialize->proc~soa_read_prologue proc~particle_soa_deserialize->interface~soa_read_field

Variables

Type Visibility Attributes Name Initial
integer(kind=int64), private :: available
integer(kind=int64), private :: cur_pos
integer(kind=int64), private :: esz
integer(kind=int64), private :: file_size
integer(kind=default_int), private :: ios
integer(kind=int64), private :: raw_count
integer(kind=int32), private :: tag

Source Code

   subroutine read_record_header(unit, expected_tag, swapped, count, ok, err)
      !! Read a record header, check the type tag, and bounds check the
      !! announced payload against the real length of the file.
      !!
      !! Comparing the payload with `inquire(size=)` before allocating is what
      !! turns a truncated or corrupt file into a clean `ERROR_IO` instead of a
      !! wild allocation followed by a short read.
      integer(default_int), intent(in) :: unit
      integer(int32), intent(in) :: expected_tag
      logical, intent(in) :: swapped
      integer(int64), intent(out) :: count
      logical, intent(out) :: ok
      type(error_t), intent(inout) :: err

      integer(default_int) :: ios
      integer(int32) :: tag
      integer(int64) :: raw_count, esz, file_size, cur_pos, available

      count = 0_int64
      ok = .false.

      read (unit, iostat=ios) tag
      call check_io(ios, "unexpected end of stream reading record tag", err)
      if (ios /= 0) return

      if (swapped) tag = bswap_int32(tag)
      if (tag /= expected_tag) then
         call err%set(ERROR_VALIDATION, "record type mismatch: expected tag "//to_char(expected_tag)// &
                      ", found "//to_char(tag))
         return
      end if

      read (unit, iostat=ios) raw_count
      call check_io(ios, "unexpected end of stream reading record length", err)
      if (ios /= 0) return

      if (swapped) raw_count = bswap_int64(raw_count)
      if (raw_count < 0_int64) then
         call err%set(ERROR_VALIDATION, "negative record element count "//to_char(raw_count))
         return
      end if

      inquire (unit, size=file_size, pos=cur_pos, iostat=ios)
      call check_io(ios, "cannot inquire stream size", err)
      if (ios /= 0) return

      esz = element_bytes(expected_tag)
      available = file_size - (cur_pos - 1_int64)
      ! Divide instead of multiplying so an absurd count cannot overflow int64.
      if (raw_count > available/esz) then
         call err%set(ERROR_IO, "truncated record: "//to_char(raw_count)//" elements announced but only "// &
                      to_char(available)//" payload bytes remain")
         return
      end if

      count = raw_count
      ok = .true.
   end subroutine read_record_header