Commit 2638ce15 authored by Thomas Jahns's avatar Thomas Jahns 🤸
Browse files

Add wrapper for some useful POSIX functionality.

parent d5422556
......@@ -54,6 +54,7 @@ libscalesppm_a_SOURCES=ppm/scales_ppm.f90 \
core/core.c core/core.h \
core/yarandom.c core/yarandom.h \
core/ppm_base.f90 core/ppm_set_default_comm.f90 \
core/ppm_posix.f90 core/ppm_posix_c.c \
core/ppm_extents.f90 core/ppm_extents_c.c \
core/ppm_strided_extents.f90 core/ppm_strided_extents_c.c \
core/qsort_r.c core/qsort_fwrap.c core/ppm_std_type_kinds.f90
......
......@@ -170,6 +170,7 @@ FCALLSCSUB2(initIRand_f,INITIALIZE_IRAND,initialize_irand,PVOID,INT)
/*
* Local Variables:
* license-project-url: "https://www.dkrz.de/redmine/projects/show/scales-ppm"
* license-markup: "doxygen"
* license-default: "bsd"
* End:
*/
MODULE ppm_posix
USE ppm_std_type_kinds, ONLY: i4, i8
IMPLICIT NONE
PRIVATE
TYPE ppm_stat
SEQUENCE
INTEGER(i4) :: st_dev, st_mode
INTEGER(i8) :: st_ino
INTEGER(i4) :: st_nlink, st_uid, st_gid, st_rdev, st_size, st_blksize
INTEGER(i8) :: st_blocks, st_atime, st_mtime, st_ctime
END TYPE ppm_stat
CHARACTER(1), PARAMETER :: dir_sep='/'
INTEGER, PARAMETER :: ppm_posix_success=0
INTEGER, PARAMETER :: max_strerror_len=255
PUBLIC :: mkdir, rmdir, stat, strerror
PUBLIC :: dir_sep, ppm_posix_success
PUBLIC :: ppm_stat
CONTAINS
SUBROUTINE mkdir(path, ierr, mode)
CHARACTER(len=*), INTENT(in) :: path
INTEGER, INTENT(out) :: ierr
INTEGER, OPTIONAL, INTENT(in) :: mode
INTERFACE
SUBROUTINE ppm_mkdir_f(path, mode, ierr)
CHARACTER(len=*), INTENT(in) :: path
INTEGER, INTENT(in) :: mode
INTEGER, INTENT(out) :: ierr
END SUBROUTINE ppm_mkdir_f
END INTERFACE
IF (PRESENT(mode)) THEN
CALL ppm_mkdir_f(path, mode, ierr)
ELSE
! 511 equals 777 octal
CALL ppm_mkdir_f(path, 511, ierr)
END IF
END SUBROUTINE mkdir
SUBROUTINE rmdir(path, ierr)
CHARACTER(len=*), INTENT(in) :: path
INTEGER, INTENT(out) :: ierr
INTERFACE
SUBROUTINE ppm_rmdir_f(path, ierr)
CHARACTER(len=*), INTENT(in) :: path
INTEGER, INTENT(out) :: ierr
END SUBROUTINE ppm_rmdir_f
END INTERFACE
CALL ppm_rmdir_f(path, ierr)
END SUBROUTINE rmdir
SUBROUTINE stat(path, buf, ierr)
CHARACTER(len=*), INTENT(in) :: path
TYPE(ppm_stat), INTENT(out) :: buf
INTEGER, INTENT(out) :: ierr
INTERFACE
SUBROUTINE stat_f(path, buf, ierr)
USE ppm_std_type_kinds, ONLY: i4, i8
TYPE ppm_stat
SEQUENCE
INTEGER(i4) :: st_dev, st_mode
INTEGER(i8) :: st_ino
INTEGER(i4) :: st_nlink, st_uid, st_gid, st_rdev, st_size, st_blksize
INTEGER(i8) :: st_blocks, st_atime, st_mtime, st_ctime
END TYPE ppm_stat
CHARACTER(len=*), INTENT(in) :: path
TYPE(ppm_stat), INTENT(out) :: buf
INTEGER, INTENT(out) :: ierr
END SUBROUTINE stat_f
END INTERFACE
CALL stat_f(path, buf, ierr)
END SUBROUTINE stat
FUNCTION is_dir(stats)
LOGICAL :: is_dir
TYPE(ppm_stat), INTENT(in) :: stats
INTERFACE
FUNCTION ppm_is_dir_f(stats)
USE ppm_std_type_kinds, ONLY: i4, i8
TYPE ppm_stat
SEQUENCE
INTEGER(i4) :: st_dev, st_mode
INTEGER(i8) :: st_ino
INTEGER(i4) :: st_nlink, st_uid, st_gid, st_rdev, st_size, st_blksize
INTEGER(i8) :: st_blocks, st_atime, st_mtime, st_ctime
END TYPE ppm_stat
TYPE(ppm_stat), INTENT(in) :: stats
LOGICAL :: ppm_is_dir_f
END FUNCTION ppm_is_dir_f
END INTERFACE
is_dir = ppm_is_dir_f(stats)
END FUNCTION is_dir
FUNCTION strerror(ierr, full_len)
CHARACTER(len=max_strerror_len) :: strerror
INTEGER, INTENT(in) :: ierr
INTEGER, OPTIONAL, INTENT(out) :: full_len
INTERFACE
SUBROUTINE strerror_f(buf, buf_len, ierr, result_len)
CHARACTER, INTENT(inout) :: buf
INTEGER, INTENT(in) :: ierr, buf_len
INTEGER, intent(out) :: result_len
END SUBROUTINE strerror_f
END INTERFACE
INTEGER :: n
strerror = " "
CALL strerror_f(strerror, max_strerror_len, ierr, n)
IF (PRESENT(full_len)) THEN
full_len = n
END IF
END FUNCTION strerror
END MODULE ppm_posix
#include <errno.h>
#include <inttypes.h>
#include <string.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <unistd.h>
#include "cfortran.h"
static void
PPM_mkdir(const char *path, int mode, int *ierr)
{
*ierr = mkdir(path, (mode_t)mode) == 0 ? 0 : errno;
}
FCALLSCSUB3(PPM_mkdir,PPM_MKDIR_F,ppm_mkdir_f,STRING,INT,PINT)
static void
PPM_rmdir(const char *path, int *ierr)
{
*ierr = rmdir(path) == 0 ? 0 : errno;
}
FCALLSCSUB2(PPM_rmdir,PPM_RMDIR_F,ppm_rmdir_f,STRING,PINT)
struct PPM_stat_f
{
int32_t ppm_st_dev, ppm_st_mode;
int64_t ppm_st_ino;
int32_t ppm_st_nlink, ppm_st_uid, ppm_st_gid, ppm_st_rdev, ppm_st_blksize;
int64_t ppm_st_size,
ppm_st_blocks,
ppm_st_atime,
ppm_st_mtime,
ppm_st_ctime;
};
static void
PPM_stat(const char *path, struct PPM_stat_f *buf, int *ierr)
{
struct stat buf_temp;
*ierr = stat(path, &buf_temp) == 0 ? 0 : errno;
buf->ppm_st_dev = (int32_t)buf_temp.st_dev;
buf->ppm_st_ino = (int64_t)buf_temp.st_ino;
buf->ppm_st_mode = (int32_t)buf_temp.st_mode;
buf->ppm_st_nlink = (int32_t)buf_temp.st_nlink;
buf->ppm_st_uid = (int32_t)buf_temp.st_uid;
buf->ppm_st_gid = (int32_t)buf_temp.st_gid;
buf->ppm_st_rdev = (int32_t)buf_temp.st_rdev;
buf->ppm_st_size = (int64_t)buf_temp.st_size;
buf->ppm_st_blksize = (int32_t)buf_temp.st_blksize;
buf->ppm_st_blocks = (int64_t)buf_temp.st_blocks;
buf->ppm_st_atime = (int64_t)buf_temp.st_atime;
buf->ppm_st_mtime = (int64_t)buf_temp.st_mtime;
buf->ppm_st_ctime = (int64_t)buf_temp.st_ctime;
}
FCALLSCSUB3(PPM_stat,STAT_F,stat_f,STRING,PVOID,PINT)
static int
PPM_is_dir(struct PPM_stat_f *stats)
{
return S_ISDIR((mode_t)stats->ppm_st_mode);
}
FCALLSCFUN1(LOGICAL,PPM_is_dir,PPM_IS_DIR_F,ppm_is_dir_f,PVOID)
static void
PPM_strerror(char *buf, int buf_len, int ierr, int *result_len)
{
const char *s = ierr != 0 ? strerror(ierr) : "";
size_t n = strlen(s);
*result_len = n;
n = n > buf_len ? buf_len : n;
memcpy(buf, s, n);
buf[n] = '\0';
}
FCALLSCSUB4(PPM_strerror,STRERROR_F,strerror_f,PSTRING,INT,INT,PINT)
/*
* Local Variables:
* license-project-url: "https://www.dkrz.de/redmine/projects/show/scales-ppm"
* license-markup "doxygen"
* license-default: "bsd"
* End:
*/
......@@ -32,7 +32,7 @@ AM_FCFLAGS = $(FPP_INCOPT)$(top_srcdir)/include/f90 \
$(FPP_INCOPT)../include/f77 \
$(FC_MOD_FLAG)../src $(MPI_FC_INCLUDE)
noinst_PROGRAMS = test_qsort test_uniform_partition test_irand
noinst_PROGRAMS = test_qsort test_uniform_partition test_irand test_posix_f
if USE_MPI
noinst_PROGRAMS+= test_strided_extents
endif
......@@ -53,6 +53,10 @@ test_irand_SOURCES = test_irand.f90
test_irand_LDADD = ../src/libscalesppm.a $(MPI_FC_LIB)
test_posix_f_SOURCES = test_posix_f.f90
test_posix_f_LDADD = ../src/libscalesppm.a
EXTRA_DIST=test_strided_extents.f90
./$(DEPDIR)/FC.deps: $(SOURCES) Makefile
......
!> test wether the exposed POSIX.1 routines work for Fortran programs
PROGRAM test_posix_f
USE ppm_posix, ONLY: dir_sep, mkdir, ppm_stat, ppm_posix_success, rmdir, &
stat, &
strerror
IMPLICIT NONE
INTEGER :: ierr
CHARACTER(len=10) :: dir_foo="foo", dir_foo_bar="foo" // dir_sep // "bar"
TYPE(ppm_stat) :: dstat
CALL mkdir(dir_foo, ierr)
IF (ierr /= ppm_posix_success) PRINT *, TRIM(strerror(ierr))
CALL mkdir(dir_foo_bar, ierr)
IF (ierr /= ppm_posix_success) PRINT *, TRIM(strerror(ierr))
CALL stat(dir_foo, dstat, ierr)
IF (ierr /= ppm_posix_success) PRINT *, TRIM(strerror(ierr))
CALL rmdir(dir_foo_bar, ierr)
IF (ierr /= ppm_posix_success) PRINT *, TRIM(strerror(ierr))
CALL rmdir(dir_foo, ierr)
IF (ierr /= ppm_posix_success) PRINT *, TRIM(strerror(ierr))
END PROGRAM test_posix_f
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment