Merge pull request #316 from urbanjost/update_new

Update subcommand "new" to reflect the addition of support for the ex…

Author: LKedward

fpm/src/fpm/cmd/new.f90

@@ -1,4 +1,5 @@
 module fpm_filesystem
+use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
     use fpm_environment, only: get_os_type, &
                                OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
                                OS_CYGWIN, OS_SOLARIS, OS_FREEBSD
@@ -7,6 +8,7 @@ module fpm_filesystem
     private
     public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, &
             mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name
+    public :: fileopen, fileclose, filewrite, warnwrite
 
     integer, parameter :: LINE_BUFFER_LEN = 1000
 
@@ -73,7 +75,7 @@ function canon_path(path) result(canon)
     ! Canonicalize path for comparison
     !  Handles path string redundancies
     !  Does not test existence of path
-    ! 
+    !
     ! To be replaced by realpath/_fullname in stdlib_os
     !
     character(*), intent(in) :: path
@@ -127,7 +129,7 @@ function canon_path(path) result(canon)
             end if
 
         end if
-        
+
 
         temp(j:j) = nixpath(i:i)
         j = j + 1
@@ -145,30 +147,28 @@ function dirname(path) result (dir)
     character(*), intent(in) :: path
     character(:), allocatable :: dir
 
-    character(:), allocatable :: file_parts(:)
-
     dir = path(1:scan(path,'/\',back=.true.))
 
 end function dirname
 
 
-logical function is_dir(dir) 
-    character(*), intent(in) :: dir 
-    integer :: stat 
+logical function is_dir(dir)
+    character(*), intent(in) :: dir
+    integer :: stat
 
-    select case (get_os_type()) 
+    select case (get_os_type())
 
     case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD)
-        call execute_command_line("test -d " // dir , exitstat=stat) 
+        call execute_command_line("test -d " // dir , exitstat=stat)
 
-    case (OS_WINDOWS) 
-        call execute_command_line('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', exitstat=stat) 
+    case (OS_WINDOWS)
+        call execute_command_line('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', exitstat=stat)
 
-    end select 
+    end select
 
-    is_dir = (stat == 0) 
+    is_dir = (stat == 0)
 
-end function is_dir 
+end function is_dir
 
 
 function join_path(a1,a2,a3,a4,a5) result(path)
@@ -315,7 +315,7 @@ recursive subroutine list_files(dir, files, recurse)
             do i=1,size(files)
                 if (is_dir(files(i)%s)) then
 
-                    call list_files(files(i)%s, dir_files, recurse=.true.) 
+                    call list_files(files(i)%s, dir_files, recurse=.true.)
                     sub_dir_files = [sub_dir_files, dir_files]
 
                 end if
@@ -347,7 +347,7 @@ function get_temp_filename() result(tempfile)
 
     type(c_ptr) :: c_tempfile_ptr
     character(len=1), pointer :: c_tempfile(:)
-    
+
     interface
 
         function c_tempnam(dir,pfx) result(tmp) bind(c,name="tempnam")
@@ -389,7 +389,7 @@ function windows_path(path) result(winpath)
         winpath(idx:idx) = '\'
         idx = index(winpath,'/')
     end do
-    
+
 end function windows_path
 
 
@@ -408,7 +408,7 @@ function unix_path(path) result(nixpath)
         nixpath(idx:idx) = '/'
         idx = index(nixpath,'\')
     end do
-    
+
 end function unix_path
 
 
@@ -464,6 +464,101 @@ subroutine delete_file(file)
     end if
 end subroutine delete_file
 
+subroutine warnwrite(fname,data)
+!> write trimmed character data to a file if it does not exist
+character(len=*),intent(in) :: fname
+character(len=*),intent(in) :: data(:)
+
+    if(.not.exists(fname))then
+        call filewrite(fname,data)
+    else
+        write(stderr,'(*(g0,1x))')'<INFO>  ',fname,&
+        & 'already exists. Not overwriting'
+    endif
+
+end subroutine warnwrite
+
+subroutine fileopen(filename,lun,ier)
+! procedure to open filename as a sequential "text" file
+
+character(len=*),intent(in)   :: filename
+integer,intent(out)           :: lun
+integer,intent(out),optional  :: ier
+integer                       :: ios
+character(len=256)            :: message
+
+    message=' '
+    ios=0
+    if(filename.ne.' ')then
+        open(file=filename, &
+        & newunit=lun, &
+        & form='formatted', &    ! FORM    = FORMATTED | UNFORMATTED
+        & access='sequential', & ! ACCESS  = SEQUENTIAL| DIRECT | STREAM
+        & action='write', &      ! ACTION  = READ|WRITE| READWRITE
+        & position='rewind', &   ! POSITION= ASIS      | REWIND | APPEND
+        & status='new', &        ! STATUS  = NEW| REPLACE| OLD| SCRATCH| UNKNOWN
+        & iostat=ios, &
+        & iomsg=message)
+    else
+        lun=stdout
+        ios=0
+    endif
+    if(ios.ne.0)then
+        write(stderr,'(*(a:,1x))')&
+        & '<ERROR> *filewrite*:',filename,trim(message)
+        lun=-1
+        if(present(ier))then
+           ier=ios
+        else
+           stop 1
+        endif
+    endif
+
+end subroutine fileopen
+
+subroutine fileclose(lun,ier)
+! simple close of a LUN.  On error show message and stop (by default)
+integer,intent(in)    :: lun
+integer,intent(out),optional :: ier
+character(len=256)    :: message
+integer               :: ios
+    if(lun.ne.-1)then
+        close(unit=lun,iostat=ios,iomsg=message)
+        if(ios.ne.0)then
+            write(stderr,'(*(a:,1x))')'<ERROR> *filewrite*:',trim(message)
+            if(present(ier))then
+               ier=ios
+            else
+               stop 2
+            endif
+        endif
+    endif
+end subroutine fileclose
+
+subroutine filewrite(filename,filedata)
+! procedure to write filedata to file filename
+
+character(len=*),intent(in)           :: filename
+character(len=*),intent(in)           :: filedata(:)
+integer                               :: lun, i, ios
+character(len=256)                    :: message
+    call fileopen(filename,lun)
+    if(lun.ne.-1)then ! program currently stops on error on open, but might
+                      ! want it to continue so -1 (unallowed LUN) indicates error
+       ! write file
+       do i=1,size(filedata)
+           write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i))
+           if(ios.ne.0)then
+               write(stderr,'(*(a:,1x))')&
+               & '<ERROR> *filewrite*:',filename,trim(message)
+               stop 4
+           endif
+       enddo
+    endif
+    ! close file
+    call fileclose(lun)
+
+end subroutine filewrite
 
 pure function to_fortran_name(string) result(res)
     ! Returns string with special characters replaced with an underscore.
@@ -475,5 +570,4 @@ pure function to_fortran_name(string) result(res)
     res = replace(string, SPECIAL_CHARACTERS, '_')
 end function to_fortran_name
 
-
 end module fpm_filesystem

fpm/src/fpm_command_line.f90

@@ -6,8 +6,8 @@
 !>
 !> Both functions additionally calculate and store a file digest (hash) which
 !> is used by the backend ([[fpm_backend]]) to skip compilation of unmodified sources.
-!> 
-!> Both functions return an instance of the [[srcfile_t]] type. 
+!>
+!> Both functions return an instance of the [[srcfile_t]] type.
 !>
 !> For more information, please read the documentation for each function:
 !>
@@ -38,7 +38,7 @@ module fpm_source_parsing
 contains
 
 !> Parsing of free-form fortran source files
-!> 
+!>
 !> The following statements are recognised and parsed:
 !>
 !> - `Module`/`submodule`/`program` declaration
@@ -171,7 +171,7 @@ function parse_f_source(f_filename,error) result(f_source)
                 if (index(adjustl(file_lines(i)%s(ic+7:)),'"') == 1 .or. &
                     index(adjustl(file_lines(i)%s(ic+7:)),"'") == 1 ) then
 
-    
+
                     n_include = n_include + 1
 
                     if (pass == 2) then
@@ -264,7 +264,7 @@ function parse_f_source(f_filename,error) result(f_source)
                     if (index(temp_string,':') > 0) then
 
                         temp_string = temp_string(index(temp_string,':')+1:)
-                        
+
                     end if
 
                     if (.not.validate_name(temp_string)) then
@@ -288,7 +288,7 @@ function parse_f_source(f_filename,error) result(f_source)
 
                 temp_string = lower(split_n(file_lines(i)%s,n=2,delims=' ',stat=stat))
                 if (stat == 0) then
-                    
+
                     if (scan(temp_string,'=(')>0 ) then
                         ! Ignore:
                         ! program =*
@@ -343,7 +343,7 @@ function validate_name(name) result(valid)
                 (name(i:i) >= '0' .and. name(i:i) <= '9').or. &
                 (lower(name(i:i)) >= 'a' .and. lower(name(i:i)) <= 'z').or. &
                 name(i:i) == '_') ) then
-                    
+
                 valid = .false.
                 return
             end if
@@ -359,7 +359,7 @@ end function parse_f_source
 
 
 !> Parsing of c source files
-!> 
+!>
 !> The following statements are recognised and parsed:
 !>
 !> - `#include` preprocessor statement
@@ -396,17 +396,17 @@ function parse_c_source(c_filename,error) result(c_source)
         c_source%unit_type = FPM_UNIT_UNKNOWN
         return
     end if
-    
+
     c_source%digest = fnv_1a(file_lines)
-    
+
     do pass = 1,2
         n_include = 0
         file_loop: do i=1,size(file_lines)
 
             ! Process 'INCLUDE' statements
             if (index(adjustl(lower(file_lines(i)%s)),'#include') == 1 .and. &
                 index(file_lines(i)%s,'"') > 0) then
-                            
+
                 n_include = n_include + 1
 
                 if (pass == 2) then
@@ -440,7 +440,7 @@ end function parse_c_source
 !> n=0  will return the last item
 !> n=-1 will return the penultimate item etc.
 !>
-!> stat = 1 on return if the index 
+!> stat = 1 on return if the index
 !>  is not found
 !>
 function split_n(string,delims,n,stat) result(substring)
@@ -476,4 +476,4 @@ function split_n(string,delims,n,stat) result(substring)
 
 end function split_n
 
-end module fpm_source_parsing
+end module fpm_source_parsing