1! { dg-do compile } 2! 3! PR fortran/51995 4! 5! Contributed by jilfa12@yahoo.com 6! 7 8MODULE factory_pattern 9 10 TYPE CFactory 11 PRIVATE 12 CHARACTER(len=20) :: factory_type !! Descriptive name for database 13 CLASS(Connection), POINTER :: connection_type !! Which type of database ? 14 CONTAINS !! Note 'class' not 'type' ! 15 PROCEDURE :: init !! Constructor 16 PROCEDURE :: create_connection !! Connect to database 17 PROCEDURE :: finalize !! Destructor 18 END TYPE CFactory 19 20 TYPE, ABSTRACT :: Connection 21 CONTAINS 22 PROCEDURE(generic_desc), DEFERRED, PASS(self) :: description 23 END TYPE Connection 24 25 ABSTRACT INTERFACE 26 SUBROUTINE generic_desc(self) 27 IMPORT :: Connection 28 CLASS(Connection), INTENT(in) :: self 29 END SUBROUTINE generic_desc 30 END INTERFACE 31 32 !! An Oracle connection 33 TYPE, EXTENDS(Connection) :: OracleConnection 34 CONTAINS 35 PROCEDURE, PASS(self) :: description => oracle_desc 36 END TYPE OracleConnection 37 38 !! A MySQL connection 39 TYPE, EXTENDS(Connection) :: MySQLConnection 40 CONTAINS 41 PROCEDURE, PASS(self) :: description => mysql_desc 42 END TYPE MySQLConnection 43 44CONTAINS 45 46 SUBROUTINE init(self, string) 47 CLASS(CFactory), INTENT(inout) :: self 48 CHARACTER(len=*), INTENT(in) :: string 49 self%factory_type = TRIM(string) 50 self%connection_type => NULL() !! pointer is nullified 51 END SUBROUTINE init 52 53 SUBROUTINE finalize(self) 54 CLASS(CFactory), INTENT(inout) :: self 55 DEALLOCATE(self%connection_type) !! Free the memory 56 NULLIFY(self%connection_type) 57 END SUBROUTINE finalize 58 59 FUNCTION create_connection(self) RESULT(ptr) 60 CLASS(CFactory) :: self 61 CLASS(Connection), POINTER :: ptr 62 63 IF(self%factory_type == "Oracle") THEN 64 IF(ASSOCIATED(self%connection_type)) DEALLOCATE(self%connection_type) 65 ALLOCATE(OracleConnection :: self%connection_type) 66 ptr => self%connection_type 67 ELSEIF(self%factory_type == "MySQL") THEN 68 IF(ASSOCIATED(self%connection_type)) DEALLOCATE(self%connection_type) 69 ALLOCATE(MySQLConnection :: self%connection_type) 70 ptr => self%connection_type 71 END IF 72 73 END FUNCTION create_connection 74 75 SUBROUTINE oracle_desc(self) 76 CLASS(OracleConnection), INTENT(in) :: self 77 WRITE(*,'(A)') "You are now connected with Oracle" 78 END SUBROUTINE oracle_desc 79 80 SUBROUTINE mysql_desc(self) 81 CLASS(MySQLConnection), INTENT(in) :: self 82 WRITE(*,'(A)') "You are now connected with MySQL" 83 END SUBROUTINE mysql_desc 84end module 85 86 87 PROGRAM main 88 USE factory_pattern 89 90 IMPLICIT NONE 91 92 TYPE(CFactory) :: factory 93 CLASS(Connection), POINTER :: db_connect => NULL() 94 95 CALL factory%init("Oracle") 96 db_connect => factory%create_connection() !! Create Oracle DB 97 CALL db_connect%description() 98 99 !! The same factory can be used to create different connections 100 CALL factory%init("MySQL") !! Create MySQL DB 101 102 !! 'connect' is a 'class' pointer. So can be used for either Oracle or MySQL 103 db_connect => factory%create_connection() 104 CALL db_connect%description() 105 106 CALL factory%finalize() ! Destroy the object 107 108 END PROGRAM main 109