diff --git a/src/core_test/Makefile b/src/core_test/Makefile index 2d7bb95f1e..e11e5dbb50 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -12,7 +12,8 @@ OBJS = mpas_test_core.o \ mpas_test_core_dmpar.o \ mpas_test_core_stream_inquiry.o \ mpas_test_openacc.o \ - mpas_test_core_stream_list.o + mpas_test_core_stream_list.o \ + mpas_test_core_io.o all: core_test @@ -44,7 +45,7 @@ mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o \ mpas_test_core_sorting.o mpas_halo_testing.o \ mpas_test_core_string_utils.o mpas_test_core_dmpar.o \ mpas_test_core_stream_inquiry.o mpas_test_openacc.o \ - mpas_test_core_stream_list.o + mpas_test_core_stream_list.o mpas_test_core_io.o mpas_test_core_halo_exch.o: diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index 2116cbf92a..163a414602 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -97,6 +97,7 @@ function test_core_run(domain) result(iErr)!{{{ use test_core_string_utils, only : mpas_test_string_utils use mpas_test_core_dmpar, only : mpas_test_dmpar use mpas_test_core_stream_inquiry, only : mpas_test_stream_inquiry + use test_core_io, only : test_core_io_test use mpas_test_core_openacc, only : mpas_test_openacc implicit none @@ -224,6 +225,18 @@ function test_core_run(domain) result(iErr)!{{{ call mpas_stream_mgr_write(domain % streamManager, forceWriteNow=.true.) + ! + ! Run io tests + ! + call mpas_log_write('') + call test_core_io_test(domain, threadErrs, iErr) + if (iErr == 0) then + call mpas_log_write('All tests PASSED') + else + call mpas_log_write('$i tests FAILED', intArgs=[iErr]) + end if + call mpas_log_write('') + ! ! Run mpas_test_openacc ! diff --git a/src/core_test/mpas_test_core_io.F b/src/core_test/mpas_test_core_io.F new file mode 100644 index 0000000000..f6f94d3247 --- /dev/null +++ b/src/core_test/mpas_test_core_io.F @@ -0,0 +1,207 @@ +! Copyright (c) 2025 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +module test_core_io + +#define ERROR_WRITE(M) call mpas_log_write( M , messageType=MPAS_LOG_ERR) +#define ERROR_WRITE_ARGS(M, ARGS) call mpas_log_write( M , ARGS, messageType=MPAS_LOG_ERR) + use mpas_log + use mpas_io + + implicit none + private + public :: test_core_io_test + + contains + + !*********************************************************************** + ! + ! routine close_file_with_message + ! + !> \brief closes the provided file handle and writes an error message. + !----------------------------------------------------------------------- + subroutine close_file_with_message(fileHandle, message, args) + type(MPAS_IO_Handle_type), intent(inout) :: fileHandle + character (len=*), intent(in), optional :: message + integer, dimension(:), intent(in), optional :: args + + integer :: local_ierr + + ! log an error message + if (present(message)) then + if (present(args)) then + ERROR_WRITE_ARGS(message, intArgs=args) + else + ERROR_WRITE(message) + end if + end if + + ! close the provided file + call MPAS_io_close(fileHandle, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ERROR_WRITE_ARGS('MPAS_io_close failed with error code:$i', intArgs=(/local_ierr/)) + return + endif + + end subroutine close_file_with_message + + !*********************************************************************** + ! + ! routine test_read_string_buffer_check + ! + !> \brief verifies attempts to read strings into buffers which are too small + !> to hold the value fails safely. + !> \details + !> Run these tests with valgrind to ensure there are no buffer overflows when + !> attempting to read strings into undersized buffers. + !----------------------------------------------------------------------- + subroutine test_read_string_buffer_check(domain, threadErrs, ierr) + + type (domain_type), intent(inout) :: domain + integer, dimension(:), intent(out) :: threadErrs + integer, intent(out) :: ierr + + integer :: local_ierr, i + type(MPAS_IO_Handle_type) :: fileHandle + character (len=StrKIND), dimension(1), parameter :: dimNamesString = ['StrLen'] + character (len=StrKIND), dimension(2), parameter :: dimNamesStringTime = ['StrLen', 'Time '] + character (len=32), parameter :: varName1 = 'stringVar' + character (len=32), parameter :: varName2 = 'stringTimeVar' + character (len=*), parameter :: varValue1 = 'This is a string' + character (len=32), dimension(2), parameter :: varNames = [varName1, varName2] + integer, parameter :: bufferSize=128 + integer, parameter :: smallBufferSize=bufferSize/2 + character (len=bufferSize) :: buffer + character (len=smallBufferSize) :: smallBuffer + character (len=*), parameter :: filename = 'char_data.nc' + + ierr = 0 + + ! open a file to write char variables to + fileHandle = MPAS_io_open(filename, MPAS_IO_WRITE, MPAS_IO_NETCDF4, domain % ioContext, & + clobber_file=.true., truncate_file=.true., ierr=local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + ERROR_WRITE('Error opening file ' // trim(filename)) + return + end if + + ! define dimensions and char variables + call MPAS_io_def_dim(fileHandle, dimNamesStringTime(1), bufferSize, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error defining '//trim(dimNamesStringTime(1))//', error=$i', (/local_ierr/)) + return + end if + call MPAS_io_def_dim(fileHandle, dimNamesStringTime(2), MPAS_IO_UNLIMITED_DIM, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error defining '//trim(dimNamesStringTime(2))//', error=$i', (/local_ierr/)) + return + end if + call MPAS_io_def_var(fileHandle, varNames(1), MPAS_IO_CHAR, dimNamesString, ierr=local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error defining var "'//trim(varNames(1))//'" error=$i', (/local_ierr/)) + return + end if + call MPAS_io_def_var(fileHandle, varNames(2), MPAS_IO_CHAR, dimNamesStringTime, ierr=local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error defining var "'//trim(varNames(2))//'" error=$i', (/local_ierr/)) + return + end if + + ! write the string values + do i=1,size(varNames) + call MPAS_io_put_var_char0d(fileHandle, varNames(i), varValue1, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error writing "'//trim(varNames(i))// & + '", error=$i', (/local_ierr/)) + return + end if + + ! verify the strings are read into buffers which are large enough for the string values + call MPAS_io_get_var_char0d(fileHandle, varNames(i), buffer, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error reading "'//trim(varNames(i))// & + '", error=$i', (/local_ierr/)) + return + end if + end do + + ! verify attempts to read strings into buffers which are too small generates an error + call mpas_log_write(' ') + call mpas_log_write('Expect to see the following error:') + call MPAS_io_err_mesg(domain % ioContext, MPAS_IO_ERR_INSUFFICIENT_BUF, .false.) + call mpas_log_write(' ') + do i=1,size(varNames) + ! this should return an error + call MPAS_io_get_var_char0d(fileHandle, varNames(i), smallBuffer, local_ierr) + call mpas_log_write(' ') + + if (local_ierr /= MPAS_IO_ERR_INSUFFICIENT_BUF) then + ierr = 1 + if (local_ierr == MPAS_IO_NOERR) then + call close_file_with_message(fileHandle, 'Expected MPAS_IO_ERR_INSUFFICIENT_BUF ($i)'& + //' but recieved no error reading "'//trim(varName1), (/local_ierr/)) + else + call close_file_with_message(fileHandle, 'Expected MPAS_IO_ERR_INSUFFICIENT_BUF ($i)'& + //' but recieved error $i reading "'//trim(varName1)//'"', & + (/MPAS_IO_ERR_INSUFFICIENT_BUF, local_ierr/)) + end if + return + end if + end do + call close_file_with_message(fileHandle) + + end subroutine test_read_string_buffer_check + + + !*********************************************************************** + ! Subroutine test_core_io_test + ! + !> \brief Core test suite for I/O + !> + !> \details This subroutine tests mpas_io features. + !> It calls individual tests for I/O operations. + !> See the subroutine body for details. + !> The results of each test are logged with a success or failure message. + !> + !> \param domain The domain object that contains the I/O context + !> \param threadErrs An array to store any errors encountered during + !> the test. + !> \param ierr The error code that indicates the result of the test. + ! + !----------------------------------------------------------------------- + subroutine test_core_io_test(domain, threadErrs, ierr) + + use mpas_log + + type (domain_type), intent(inout) :: domain + integer, dimension(:), intent(out) :: threadErrs + integer, intent(out) :: ierr + + integer :: test_status + + ierr = 0 + test_status = 0 + + call mpas_log_write('Testing char-0 buffer reads') + call test_read_string_buffer_check(domain, threadErrs, test_status) + if (test_status == 0) then + call mpas_log_write('char-0 buffer tests: SUCCESS') + else + call mpas_log_write('char-0 buffer tests: FAILURE', MPAS_LOG_ERR) + ierr = ierr + abs(test_status) + end if + + + end subroutine test_core_io_test + +end module test_core_io diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 09514a3667..01c05a0ce9 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -7,6 +7,9 @@ ! module mpas_io +#define COMMA , +#define IO_DEBUG_WRITE(M) !call mpas_log_write(M) +#define IO_ERROR_WRITE(M) call mpas_log_write( M, messageType=MPAS_LOG_ERR) use mpas_derived_types use mpas_attlist use mpas_dmpar @@ -1847,6 +1850,13 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr character (len=:), pointer :: charVal_p character (len=:), dimension(:), pointer :: charArray1d_p + ! local variables returned from MPAS_io_inq_var + integer :: fieldtype + integer :: ndims + integer, dimension(:), pointer :: dimsizes + character (len=StrKIND), dimension(:), pointer :: dimnames + character (len=StrKIND) :: message + #ifdef MPAS_SMIOL_SUPPORT type (SMIOLf_decomp), pointer :: null_decomp @@ -1984,22 +1994,41 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr ! call mpas_log_write(' value is char') charVal_p => charVal + + ! get the dimension of the char variable to ensure the provided output buffer is large enough + call MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsizes, local_ierr) + do i = 1, ndims + message = ' MPAS_io_get_var_generic len(charVal):$i var "'//trim(fieldname)// & + '" type is $i dim is $i '// trim(dimnames(i))//' size is $i' + IO_DEBUG_WRITE(message COMMA intArgs=(/len(charVal), fieldtype, i, dimsizes(i)/)) + end do + ! because charVal is provided, assume dimension 1 is the string length + if (dimsizes(1) > len(charVal)) then + local_ierr = MPAS_IO_ERR_INSUFFICIENT_BUF + message = 'Length of string variable "'//trim(fieldname)//'" in file "'//trim(handle % filename)//'"' + IO_ERROR_WRITE(message) + message = ' exceeds buffer size: len('//trim(fieldname)//')=$i, len(buffer)=$i' + IO_ERROR_WRITE(message COMMA intArgs=(/dimsizes(1), len(charVal)/)) + else #ifdef MPAS_SMIOL_SUPPORT - local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) #endif #ifdef MPAS_PIO_SUPPORT - if (field_cursor % fieldhandle % has_unlimited_dim) then - count2(1) = field_cursor % fieldhandle % dims(1) % dimsize - pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar) - charVal(1:count2(1)) = tempchar(1)(1:count2(1)) - else - start1(1) = 1 - count1(1) = field_cursor % fieldhandle % dims(1) % dimsize - pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar) - charVal(1:count1(1)) = tempchar(1)(1:count1(1)) - end if + if (field_cursor % fieldhandle % has_unlimited_dim) then + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar) + charVal(1:count2(1)) = tempchar(1)(1:count2(1)) + else + start1(1) = 1 + count1(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar) + charVal(1:count1(1)) = tempchar(1)(1:count1(1)) + end if #endif + end if + deallocate(dimsizes) + deallocate(dimnames) else if (present(charArray1d)) then ! call mpas_log_write(' value is char1') #ifdef MPAS_PIO_SUPPORT @@ -2765,6 +2794,12 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr end if ! call mpas_log_write('Checking for error') + if (local_ierr == MPAS_IO_ERR_INSUFFICIENT_BUF) then + call MPAS_io_err_mesg(handle % ioContext, local_ierr, .false.) + io_global_err = local_ierr + if (present(ierr)) ierr = local_ierr + return + endif #ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then io_global_err = pio_ierr @@ -6498,6 +6533,10 @@ subroutine MPAS_io_err_mesg(ioContext, ierr, fatal) call mpas_log_write('MPAS IO Error: Would clobber existing file', MPAS_LOG_ERR) case (MPAS_IO_ERR_NOEXIST_READ) call mpas_log_write('MPAS IO Error: Attempting to read a file which does not exist.', MPAS_LOG_ERR) + case (MPAS_IO_ERR_MISSING_DIM) + call mpas_log_write('MPAS IO Error: Attempting to read a dimension which does not exist.', MPAS_LOG_ERR) + case (MPAS_IO_ERR_INSUFFICIENT_BUF) + call mpas_log_write('MPAS IO Error: Attempting to read a variable into a buffer of insufficient size.', MPAS_LOG_ERR) case default call mpas_log_write('MPAS IO Error: Unrecognized error code...', MPAS_LOG_ERR) end select diff --git a/src/framework/mpas_io_types.inc b/src/framework/mpas_io_types.inc index 522e6e1ad5..dc7551857a 100644 --- a/src/framework/mpas_io_types.inc +++ b/src/framework/mpas_io_types.inc @@ -65,7 +65,8 @@ MPAS_IO_ERR_UNIMPLEMENTED = -18, & MPAS_IO_ERR_WOULD_CLOBBER = -19, & MPAS_IO_ERR_NOEXIST_READ = -20, & - MPAS_IO_ERR_MISSING_DIM = -21 + MPAS_IO_ERR_MISSING_DIM = -21, & + MPAS_IO_ERR_INSUFFICIENT_BUF = -22 type MPAS_IO_Handle_type logical :: initialized = .false.