bug fix in uppercase/lowercase functions

added some more string functions and unit tests.

Author: jacobwilliams

src/string_module.f90

@@ -13,6 +13,9 @@ module string_module
     character(len=*),parameter :: upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' !! uppercase characters
 
     public :: lowercase,uppercase
+    public :: replace_char
+    public :: reverse
+    public :: lchop, rchop
 
     contains
 !*****************************************************************************************
@@ -21,16 +24,14 @@ module string_module
 !>
 !  Convert the string to uppercase.
 
-    subroutine uppercase(str)
-
-    implicit none
+    pure subroutine uppercase(str)
 
     character(len=*),intent(inout) :: str
 
     integer :: i,idx
 
     do i=1,len_trim(str)
-        idx = index(str(i:i),lower)
+        idx = index(lower,str(i:i))
         if (idx>0) str(i:i) = upper(idx:idx)
     end do
 
@@ -41,21 +42,116 @@ end subroutine uppercase
 !>
 !  Convert the string to lowercase.
 
-    subroutine lowercase(str)
-
-    implicit none
+    pure subroutine lowercase(str)
 
     character(len=*),intent(inout) :: str
 
     integer :: i,idx
 
     do i=1,len_trim(str)
-        idx = index(str(i:i),upper)
+        idx = index(upper,str(i:i))
         if (idx>0) str(i:i) = lower(idx:idx)
     end do
 
     end subroutine lowercase
 !*****************************************************************************************
 
-    end module string_module
 !*****************************************************************************************
+!>
+!  Replace all occurrences of a single character `s1` in `str` with `s2`.
+
+    pure function replace_char(str, s1, s2) result(newstr)
+
+    character(len=*),intent(in) :: str  !! original string
+    character(len=1),intent(in) :: s1   !! find all occurrences of this character
+    character(len=1),intent(in) :: s2   !! replace with this character
+    character(len=:),allocatable :: newstr !! new string
+
+    integer :: i !! counter
+
+    newstr = str
+    do i = 1, len(newstr)
+        if (newstr(i:i) == s1) newstr(i:i) = s2
+    end do
+
+    end function replace_char
+!*****************************************************************************************
+
+!*****************************************************************************************
+!>
+!  Chop leading `chars` string from `str`.
+!  Note that trailing spaces are not ignored in either string.
+
+    pure function lchop(str, chars) result(newstr)
+
+    character(len=*),intent(in) :: str  !! original string
+    character(len=*),intent(in) :: chars !! characters to strip
+    character(len=:),allocatable :: newstr !! new string
+
+    ! this logic here is to account for trailing spaces, which we preserve
+    if (len(chars)>len(str)) then
+        newstr = str  ! not possible to chop
+    else
+        if (str==chars) then
+            if (len(str)>len(chars)) then
+                newstr = str(len(chars)+1:)  ! only trailing spaces remain
+            else
+                newstr = ''  ! string is now empty
+            end if
+        else
+            if (index(str,chars) == 1) then
+                newstr = str(len(chars)+1:)  ! chop leading chars, keep rest of string
+            else
+                newstr = str  ! original string, noting to chop
+            end if
+        end if
+    end if
+
+    end function lchop
+!*****************************************************************************************
+
+!*****************************************************************************************
+!>
+!  Chop trailing `chars` string from `str`.
+!  Note that trailing spaces are not ignored in either string.
+
+    pure function rchop(str, chars) result(newstr)
+
+    character(len=*),intent(in) :: str  !! original string
+    character(len=*),intent(in) :: chars !! characters to strip
+    character(len=:),allocatable :: newstr !! new string
+
+    newstr = reverse(lchop(reverse(str), reverse(chars)))
+
+    end function rchop
+!*****************************************************************************************
+
+!*****************************************************************************************
+!>
+!  Reverse a string.
+
+    pure function reverse(str) result(newstr)
+
+    character(len=*),intent(in) :: str  !! original string
+    character(len=:),allocatable :: newstr !! new string
+    integer :: i, j !! counter
+    integer :: n !! length of `str`
+
+    n = len(str)
+    allocate(character(len=n) :: newstr)
+    if (n==0) then
+        newstr = ''
+    else
+        j = 0
+        do i = n, 1, -1
+            j = j + 1
+            newstr(j:j) = str(i:i)
+        end do
+    end if
+
+    end function reverse
+!*****************************************************************************************
+
+!*****************************************************************************************
+    end module string_module
+!*****************************************************************************************

test/string_test.f90

@@ -0,0 +1,34 @@
+!*****************************************************************************************
+!>
+!  Test program for the string routines.
+
+    program string_test
+
+    use string_module
+
+    implicit none
+
+    character(len=:),allocatable :: s1
+
+    s1 = 'Hello, World!'
+    call uppercase(s1)
+    if (s1 /= 'HELLO, WORLD!') error stop 'uppercase test failed: '//s1
+
+    s1 = 'Hello, World!'
+    call lowercase(s1)
+    if (s1 /= 'hello, world!') error stop 'lowercase test failed: '//s1
+
+    s1 = replace_char('banana', 'a', 'o')
+    if (s1 /= 'bonono') error stop 'replace char test failed: '//s1
+
+    s1 = reverse('stressed')
+    if (s1 /= 'desserts') error stop 'reverse test failed: '//s1
+
+    s1 = lchop('abc efg', 'abc')
+    if (s1 /= ' efg' .and. len(s1)/=4) error stop 'lchop test failed: '//s1
+
+    s1 = rchop('abc efg', 'efg')
+    if (s1 /= 'abc' .and. s1(4:4) /= ' ') error stop 'rchop test failed: '//s1
+
+    end program string_test
+!*****************************************************************************************