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: libjust4
  • 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/libjust4/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/libjust4/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 penv

C 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]\n","REWIND TABLE",variable);
      */
      my_initenv();                                  /* reset pointer to start of table */
   }else{
      *length=strlen(*ep);
      /*variable = *ep;*/
      strncpy(variable,*ep,*length+1);
      *ep=*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
./xxenv

Note that simpler examples are included in the module source for each public procedure.

category: code