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