Fortran Wiki
xxenv
Environment Table Interface
The xxenv(1) program prints the environment table as-is, in a format for use with the Bourne-shell family of shells, or in a format for use with the C-shell family of shells. The program’s purpose is to demonstrate the module XENV that uses a small C wrapper along with the intrinsic ISO_C_BINDING module to allow Fortran programs to access the environment table and to set and unset environment variables versus just being able to read them (via the intrinisic GET_ENVIRONMENT_VARIABLE(3f)) in a (hopefully) portable manner.
- if you make enhancements feel free to incorporate them into this source
- This was only tested with gfortran 5.4+ on Linux and Cygwin platforms. I would be very interested in feedback from builds in other programming environments.
- extracted from a work-in-progress that is a collection of Fortran/C codes that support general-purpose CLI/TDU programs written in Fortran: libGPF
- I would prefer to eliminate or at least minimize the C wrapper code, but this, after several tries, is what worked on my platforms – Caveat emptor.
Fortran Code
!ENVIRONMENT ACCESS
! o system_putenv(3f): call putenv(3c)
! o system_clearenv(3f): emulate clearenv(3c) to clear environment
! o system_unsetenv(3f): call unsetenv(3c) to remove variable from environment
! o set_environment_variable(3f): set environment variable by calling etenv(3c)
! o system_initenv(3f): initialize environment table for reading
! o system_readenv(3f): read next entry from environment table
module M_env
use,intrinsic :: iso_c_binding, only: c_float, c_int, c_char
use,intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_null_char
use,intrinsic :: iso_c_binding
implicit none
private
public :: system_putenv
public :: set_environment_variable
public :: system_clearenv
public :: system_unsetenv
public :: system_initenv
public :: system_readenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!NAME
! system_initenv(3f) - initialize environment table pointer and size so table can be read by readenv(3f)
!SYNOPSIS
! subroutine system_initenv()
!DESCRIPTION
! A simple interface allows reading the environment variable table
! of the process. Call system_initenv(3f) to initialize reading the
! environment table, then call system_readenv(3f) until a blank line
! is returned. If more than one thread reads the environment or the
! environment is changed while being read the results are undefined.
!
!EXAMPLE
! Sample program:
!
! program demo_system_initenv
! use M_env, only : system_initenv, system_readenv
! character(len=:),allocatable :: string
! call system_initenv()
! do
! string=system_readenv()
! if(string.eq.'')then
! exit
! else
! write(*,'(a)')string
! endif
! enddo
! end program demo_system_initenv
!
! Sample results:
!
! USERDOMAIN_ROAMINGPROFILE=buzz
! HOMEPATH=\Users\JSU
! APPDATA=C:\Users\JSU\AppData\Roaming
! MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man:::
! DISPLAYNUM=0
! ProgramW6432=C:\Program Files
! HOSTNAME=buzz
! XKEYSYMDB=/usr/share/X11/XKeysymDB
! PUBLISH_CMD=
! OnlineServices=Online Services
! :
! :
! :
character(len=*),parameter :: ident_initenv="@(#)M_env::system_initenv(3f): initialize environment table for reading"
integer(kind=c_long),bind(c,name="longest_env_variable") :: longest_env_variable
interface
subroutine system_initenv() bind (C,NAME='my_initenv')
end subroutine system_initenv
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!NAME
! system_putenv(3f) - set environment variable from Fortran by calling putenv(3c)
!
!SYNOPSIS
! subroutine system_putenv(string, err)
!
! character(len=*),intent(in) :: string
! integer, optional, intent(out) :: err
!
!DESCRIPTION
! The system_putenv() function adds or changes the value of environment variables.
! The argument string is of the form name=value.
! If name does not already exist in the environment, then string is added to the environment.
! If name does exist, then the value of name in the environment is changed to value.
! The string passed to putenv(3c) becomes part of the environment,
! so this routine creates a string each time it is called that increases the amount of
! memory the program uses.
!
!RETURN VALUE
! The system_putenv() function returns zero on success, or nonzero if an error occurs.
! A non-zero error usually indicates sufficient memory does not exist to store the
! variable.
!
!EXAMPLE
! Sample setting an environment variable from Fortran:
!
! program demo_system_putenv
! use M_env, only: system_putenv
! use iso_c_binding
! implicit none
! integer :: ierr
!
! write(*,'(a)')'no environment variables containing "GRU":'
! call execute_command_line('env|grep GRU')
!
! call system_putenv('GRU=this is the value',ierr)
! write(*,'(a,i0)')'now "GRU" should be defined: ',ierr
! call execute_command_line('env|grep GRU')
!
! call system_putenv('GRU2=this is the second value',ierr)
! write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined: ',ierr
! call execute_command_line('env|grep GRU')
!
! call system_putenv('GRU2',ierr)
! call system_putenv('GRU',ierr)
! write(*,'(a,i0)')'should be gone, varies with different putenv(3c): ',ierr
! call execute_command_line('env|grep GRU')
! write(*,'(a)')'system_unsetenv(3f) is a better way to remove variables'
!
! end program demo_system_putenv
!
! Results:
!
! no environment variables containing "GRU":
! now "GRU" should be defined: 0
! GRU=this is the value
! now "GRU" and "GRU2" should be defined: 0
! GRU2=this is the second value
! GRU=this is the value
! should be gone, varies with different putenv(3c): 0
! system_unsetenv(3f) is a better way to remove variables
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
subroutine system_putenv(string, err)
character(len=*),parameter :: ident="@(#)M_env::system_putenv(3f): call putenv(3c)"
interface
integer(kind=c_int) function c_putenv(c_string) bind(C,name="putenv")
import c_int, c_char
character(kind=c_char) :: c_string(*)
end function
end interface
character(len=*),intent(in) :: string
integer, optional, intent(out) :: err
integer :: loc_err
integer :: i
! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit
character(len=1,kind=c_char),save, pointer :: memleak(:)
allocate(memleak(len(string)+1))
do i=1,len(string)
memleak(i)=string(i:i)
enddo
memleak(len(string)+1)=c_null_char
loc_err = c_putenv(memleak)
if (present(err)) err = loc_err
end subroutine system_putenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!NAME
! set_environment_variable(3f) - call setenv(3c) to set environment variable
!SYNOPSIS
! subroutine set_environment_variable(NAME, VALUE, STATUS)
!
! character(len=*) :: NAME
! character(len=*) :: VALUE
! integer, optional, intent(out) :: STATUS
!DESCRIPTION
!EXAMPLE
!$DOCUMENT END
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
subroutine set_environment_variable(NAME, VALUE, STATUS)
character(len=*),parameter :: ident="@(#)M_env::set_environment_variable(3f): call setenv(3c) to set environment variable"
character(len=*) :: NAME
character(len=*) :: VALUE
integer, optional, intent(out) :: STATUS
integer :: loc_err
interface
integer(kind=c_int) function c_setenv(c_name,c_VALUE) bind(C,NAME="setenv")
import c_int, c_char
character(kind=c_char) :: c_name(*)
character(kind=c_char) :: c_VALUE(*)
end function
end interface
loc_err = c_setenv(str2arr(trim(NAME)),str2arr(VALUE))
if (present(STATUS)) STATUS = loc_err
end subroutine set_environment_variable
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!NAME
! system_clearenv(3f) - clear environment by calling clearenv(3c)
!SYNOPSIS
!
!DESCRIPTION
! The clearenv() procedure clears the environment of all name-value pairs.
! Typically used in security-conscious applications or ones where configuration
! control requires ensuring specific variables are set.
!
!RETURN VALUES
! ierr returns zero on success, and a nonzero value on failure. Optional.
! If not present and an error occurs the program stops.
!
!EXAMPLE
!
! Sample program:
!
! program demo_system_clearenv
! use M_env, only : system_clearenv
! implicit none
! ! environment before clearing
! call execute_command_line('env|wc')
! ! environment after clearing (not necessarily blank!!)
! call system_clearenv()
! call execute_command_line('env')
! end program demo_system_clearenv
!
! Typical output:
!
! 89 153 7427
! PWD=/home/urbanjs/V600
! SHLVL=1
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
subroutine system_clearenv(ierr)
! emulating because not available on some platforms
character(len=*),parameter :: ident="@(#)M_env::system_clearenv(3f): emulate clearenv(3c) to clear environment"
integer,intent(out),optional :: ierr
character(len=:),allocatable :: string
integer :: ierr_local1, ierr_local2
ierr_local2=0
INFINITE: do
call system_initenv() ! important -- changing table causes undefined behavior so reset after each unsetenv
string=system_readenv() ! get first name=value pair
if(string.eq.'') exit INFINITE
call system_unsetenv(string(1:index(string,'=')-1) ,ierr_local1) ! remove first name=value pair
if(ierr_local1.ne.0)ierr_local2=ierr_local1
enddo INFINITE
if(present(ierr))then
ierr=ierr_local2
elseif(ierr_local2.ne.0)then ! if error occurs and not being returned, stop
write(*,*)'*system_clearenv* error=',ierr_local2
stop
endif
end subroutine system_clearenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!NAME
! system_unsetenv(3f) - change or add an environment variable by calling unsetenv(3c)
!SYNOPSIS
! subroutine system_unsetenv(name,ierr)
!
! character(len=*),intent(in) :: name
! integer,intent(out),optional :: ierr
!
!DESCRIPTION
!
! The system_unsetenv(3f) function deletes the variable name from the
! environment. If name does not exist in the environment, then the
! function succeeds, and the environment is unchanged.
!
!RETURN VALUE
!
! The system_unsetenv(3f) function returns zero on success, or -1 on error.
! name is NULL, points to a string of length 0, or contains an '=' character.
! Insufficient memory to add a new variable to the environment.
!
!EXAMPLE
! Sample program:
!
! program demo_system_unsetenv
! use M_env, only : system_unsetenv, system_putenv
! implicit none
! call system_putenv('GRU=this is the value')
! write(*,'(a)')'The variable GRU should be set'
! call execute_command_line('env|grep GRU')
! call unsetenv('GRU')
! write(*,'(a)')'The variable GRU should not be set'
! call execute_command_line('env|grep GRU')
! end program demo_system_unsetenv
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
subroutine system_unsetenv(name,ierr)
character(len=*),parameter :: ident="@(#)M_env::system_unsetenv(3f): call unsetenv(3c) to remove variable from environment"
character(len=*),intent(in) :: name
integer,intent(out),optional :: ierr
integer :: ierr_local
interface
integer(kind=c_int) function c_unsetenv(c_name) bind(C,NAME="unsetenv")
import c_int, c_char
character(len=1,kind=c_char) :: c_name(*)
end function
end interface
ierr_local = c_unsetenv(str2arr(trim(NAME)))
if(present(ierr))then
ierr=ierr_local
elseif(ierr_local.ne.0)then ! if error occurs and not being returned, stop
write(*,*)'*system_unsetenv* error=',ierr_local
stop
endif
end subroutine system_unsetenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!NAME
! system_readenv(3f) - step thru and read environment table
!SYNOPSIS
! function system_readenv() result(string)
!
! character(len=:),allocatable :: string
!DESCRIPTION
! A simple interface allows reading the environment variable table of the process. Call
! system_initenv(3f) to initialize reading the environment table, then call system_readenv(3f)
! until a blank line is returned. If more than one thread
! reads the environment or the environment is changed while being read the results are undefined.
!
!EXAMPLE
! Sample program:
!
! program demo_system_initenv
! use M_env, only : system_initenv, system_readenv
! character(len=:),allocatable :: string
! call system_initenv()
! do
! string=system_readenv()
! if(string.eq.'')then
! exit
! else
! write(*,'(a)')string
! endif
! enddo
! end program demo_system_initenv
!
! Sample results:
!
! USERDOMAIN_ROAMINGPROFILE=buzz
! HOMEPATH=\Users\JSU
! APPDATA=C:\Users\JSU\AppData\Roaming
! MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man:::
! DISPLAYNUM=0
! ProgramW6432=C:\Program Files
! HOSTNAME=buzz
! XKEYSYMDB=/usr/share/X11/XKeysymDB
! PUBLISH_CMD=
! OnlineServices=Online Services
! :
! :
! :
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
function system_readenv() result(string)
character(len=*),parameter :: ident="@(#)M_env::system_readenv(3f): read next entry from environment table"
character(len=:),allocatable :: string
integer(kind=c_size_t) :: c_length
character(kind=c_char) :: c_buff(longest_env_variable+1)
interface
subroutine c_readenv(c_string,c_length) bind (C,NAME='my_readenv')
import c_char, c_int, c_ptr, c_size_t
character(kind=c_char),intent(out) :: c_string(*)
integer(kind=c_size_t) :: c_length
end subroutine c_readenv
end interface
call c_readenv(c_buff,c_length)
string=trim(arr2str(c_buff))
end function system_readenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
pure function arr2str(array) result (string)
character(len=*),parameter :: ident="@(#)M_env::arr2str(3fp): function copies null-terminated char array to string"
character(len=1),intent(in) :: array(:)
character(len=size(array)) :: string
integer :: i
string=' '
do i = 1,size(array)
if(array(i).eq.char(0))then
exit
else
string(i:i) = array(i)
endif
enddo
end function arr2str
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
pure function str2arr(string) result (array)
character(len=*),parameter :: ident="@(#)M_env::str2arr(3fp): function copies string to null terminated char array"
character(len=*),intent(in) :: string
character(len=1,kind=c_char) :: array(len(string)+1)
integer :: i
do i = 1,len_trim(string)
array(i) = string(i:i)
enddo
array(size(array))=c_null_char
end function str2arr
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
end module M_env
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================Demonstration Program
program penv
use M_env, only : system_initenv, system_readenv
implicit none
character(len=:),allocatable :: printtype
character(len=:),allocatable :: string
logical :: Bsyntax=.false.,Csyntax=.false.
integer :: length, status
!-----------------------------------------------------------------------------------------------------------------------------------
! use an environment variable to determine output format instead of cracking command line as example
call get_environment_variable('XENV',length=length,status=status)
if(length.eq.0.or.status.ne.0)then
string='default'
else
allocate(character(len=length) :: string)
call get_environment_variable('XENV',string)
endif
string=string//' '
select case(string(1:1))
case('c','C')
Csyntax=.true.
case('b','B')
Bsyntax=.true.
case default
end select
!-----------------------------------------------------------------------------------------------------------------------------------
call system_initenv() ! set to beginning of table
do ! iterate through environment table
string=system_readenv()
if(string.eq.'')exit ! if a blank line is returned assume end reached
call printformatted() ! print variable
enddo
!-----------------------------------------------------------------------------------------------------------------------------------
contains
!-----------------------------------------------------------------------------------------------------------------------------------
subroutine printformatted()
integer :: ii
if(Bsyntax)then
ii=index(string,'=')
write(*,'("export ''",a,"''=")',advance='no')string(1:ii-1)
write(*,'(a)')printquoted_SH(string(ii+1:))
elseif(Csyntax)then
ii=index(string,'=')
write(*,'("setenv ",a)',advance='no')printquoted_CSH(string(1:ii-1))
write(*,'(1x,a)')printquoted_CSH(string(ii+1:))
else
write(*,'(a)')trim(string)
endif
end subroutine printformatted
!-----------------------------------------------------------------------------------------------------------------------------------
function printquoted_SH(string) result (quoted)
! print variable names and variable values with quotes and special escaping of ' for sh(1) shell
character(len=*),intent(in) :: string
character(len=:),allocatable :: quoted
integer :: i
character :: c
quoted="'"
do i=1,len(string)
c=string(i:i)
select case(c)
case ("'")
quoted=quoted//"'\''"
case default
quoted=quoted//c
end select
enddo
quoted=quoted//"'"
end function printquoted_SH
!-----------------------------------------------------------------------------------------------------------------------------------
function printquoted_CSH(string) result (quoted)
! print variable names and variable values with quotes and special escaping of ' and ! for csh(1) shell
character(len=*),intent(in) :: string
character(len=:),allocatable :: quoted
integer :: i
character :: c
quoted="'"
do i=1,len(string)
c=string(i:i)
select case(c)
case ("'")
quoted=quoted//"'\''"
case ('!')
quoted=quoted//"\!"
case default
quoted=quoted//c
end select
enddo
quoted=quoted//"'"
end function printquoted_CSH
!-----------------------------------------------------------------------------------------------------------------------------------
end program penvC code
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/types.h>
#include <sys/utsname.h>
#include <unistd.h>
#include <fcntl.h>
#include <sys/stat.h>
#include <strings.h>
extern char **environ;
char **ep;
int longest_env_variable=4096;
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
wrapper to step through environment table
*/
void my_initenv(){
/*
Set pointer into environment table to beginning of table,
but find longest current variable length so can make buffer
big enough by scanning current table. There is probably a
C variable that defines this length; but hopefully this
entire method of reading the environment table will be
superceeded if I can figure out what is wrong with the
version that returns an arbitrary string length directly.
See:
xargs --show-limits
*/
long int newlength;
ep=environ;
longest_env_variable=4096;
while ((*ep)){
newlength=(long int)strlen(*ep);
if(newlength > longest_env_variable){
longest_env_variable=newlength;
}
*ep++;
}
ep=environ;
}
void my_readenv(char *variable, size_t *length){
if ( *ep == NULL ){
*length=0;
strncpy(variable,"",1);
/*
fprintf(stdout,"%s [%s]\
","REWIND TABLE",variable);
*/
my_initenv(); /* reset pointer to start of table */
}else{
*length=strlen(*ep);
/*variable = *ep;*/
strncpy(variable,*ep,*length+1);
*ep++;
}
}
/*--------------------------------------------------------------------------------------------------------------------------------*/example Bash shell code
This bash shell demonstrates building and executing the example program. Assuming the module and example program are in xenv.f90 and the C code is in xenv_c.c :
#/bin/bash
cc -c xenv_c.c
gfortran xenv.f90 xenv_c.o -o xxenv
export XENV=B
./xxenv
export XENV=C
./xxenv
export XENV=default
./xxenvNote that simpler examples are included in the module source for each public procedure.
category: code