ViewVC Help
View File | Revision Log | Show Annotations | Root Listing
root/Genquire/GenquireINIT.pm
Revision: 1.10
Committed: Tue Apr 22 17:21:30 2003 UTC (13 years, 4 months ago) by markw
Branch: MAIN
CVS Tags: Release4, HEAD
Changes since 1.9: +1 -1 lines
Log Message:
windows friendly 'do gq_whatever.cnf' added

Line File contents
1 package GenquireINIT;
2
3 use strict;
4 use Carp;
5 use vars qw(
6 $AUTOLOAD
7 @ISA
8
9 $context
10
11 @Organisms
12 $Username
13 $Password
14 $Filename
15 $IPAddress
16 $Default_DB
17 );
18 use Tk::ErrorDialog;
19 use Tk::BrowseEntry;
20 use GQ::Server::DB::Context;
21 use GQ::Server::DB::DbObj;
22 use GQ::Client::QueryScreen;
23 @ISA = qw(Tk::MainWindow);
24
25 {
26 #Encapsulated class data
27
28 #___________________________________________________________
29 #ATTRIBUTES
30 my %_attr_data = # DEFAULT ACCESSIBILITY
31 (
32 top => [undef, 'read/write'], # this is the MainWindow
33 QS => [undef, 'read/write'], # holds the query screen
34
35 # variables needed by all of Genquire
36 DATA_SOURCES=> [undef, 'read/write'], # list of datasource names and .cfg files from genquire.conf
37 BLAST_URL => [undef, 'read/write'], # list of datasource names and .cfg files from genquire.conf
38 BLAST_CONFIG=> [undef, 'read/write'], # anon hash of the parameters for Blasting (eg. -p, -d,) and how they map onto your specific CGI interface
39 TEMP_DIR => [undef, 'read/write'], # full path to /tmp
40 WORKING_DIR => [undef, 'read/write'], # full path to a directory which is read/writeable for input and output.
41 PLUGINS_DIR => [undef, 'read/write'], # full path to a directory which is read/writeable for input and output.
42 BROWSER => [undef, 'read/write'], # full path to a directory which is read/writeable for input and output.
43
44 # variables used by this GUI window
45 txtFilename => [undef, 'read/write'], # these are references to GUI elements
46 txtUsername => [undef, 'read/write'], # that are needed in various places
47 txtPassword => [undef, 'read/write'], #
48 lbxOrganism => [undef, 'read/write'], #
49 lbxDataSource =>[undef, 'read/write'], #
50 txtIPAddress => [undef, 'read/write'], #
51
52 );
53
54 #_____________________________________________________________
55
56 # METHODS, to operate on encapsulated class data
57
58 # Is a specified object attribute accessible in a given mode
59 sub _accessible {
60 my ($self, $attr, $mode) = @_;
61 $_attr_data{$attr}[1] =~ /$mode/
62 }
63
64 # Classwide default value for a specified object attribute
65 sub _default_for {
66 my ($self, $attr) = @_;
67 $_attr_data{$attr}[0];
68 }
69
70 # List of names of all specified object attributes
71 sub _standard_keys {
72 keys %_attr_data;
73 }
74
75 }
76
77 sub new {
78 my ($caller, %args) = @_;
79 my $context;
80 my $caller_is_obj = ref($caller);
81 my $class = $caller_is_obj || $caller;
82
83 my $top = MainWindow->new;
84 my $self = bless $top, $class;
85
86 foreach my $attrname ( $self->_standard_keys ) {
87 if (exists $args{$attrname}) {
88 $self->{$attrname} = $args{$attrname} }
89 elsif ($caller_is_obj) {
90 $self->{$attrname} = $caller->{$attrname} }
91 else {
92 $self->{$attrname} = $self->_default_for($attrname) }
93 }
94
95 return 0 unless ($self->TEMP_DIR && $self->WORKING_DIR && $self->DATA_SOURCES);
96 $self->top($top);
97
98 $self->title("Genquire");
99 my $ttframe = $self->Frame(-relief => 'ridge', -borderwidth => '5', -background => 'lightblue');
100 my $tframe = $self->Frame(-relief => 'ridge', -borderwidth => '2', -background => 'white');
101 my $bframe = $self->Frame(-relief => 'ridge', -borderwidth => '5', -background => 'red');
102
103 my $lbldatasource = $ttframe->Label(-text => " SELECT DATA SOURCE ", -background => 'lightblue')->pack(-side => "top", -anchor => 'w');
104 $self->lbxDataSource($ttframe->BrowseEntry(
105 -listwidth => 75,-background => 'lightblue',
106 -variable=>\$self->{selDataSource},
107 -browsecmd => sub {
108 $context = $self->attemptConnection;
109 unless ($context){
110 $self->GenerateErrorMessage("Attempt to connect to this datasource failed. Config file for this datasource may be incorrect.");
111 }
112 }
113 )
114 );
115
116 my $lblorganism = $tframe->Label(-text => "data source", -background => 'white')->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x');
117 $self->lbxOrganism($tframe->BrowseEntry(-listwidth => 85,
118 -background => 'white',
119 -variable => \$self->{selOrganism}, # variable holds the contents of the widget
120 )->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x'));
121
122 my $lblfilename = $tframe->Label(-text => "filename", -background => 'white')->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x');
123 $self->txtFilename($tframe->Entry(-width => 25,
124 -background => 'white',
125 -textvariable => \$self->{selFilename}, # variable holds the contents of the widget
126 )->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x'));
127
128 my $lblusername = $tframe->Label(-text => "username", -background => 'white')->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x');
129 $self->txtUsername($tframe->Entry(-width => 15,
130 -background => 'white',
131 -textvariable => \$self->{selUsername}, # variable holds the contents of the widget
132 )->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x'));
133
134 my $lblpassword = $tframe->Label(-text => "password", -background => 'white')->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x');
135 $self->txtPassword($tframe->Entry(-width => 15,
136 -show => "*",
137 -background => 'white',
138 -textvariable => \$self->{selPassword}, # variable holds the contents of the widget
139 )->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x'));
140
141 my $lblipaddress = $tframe->Label(-text => "URL/IP", -background => 'white')->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x');
142 $self->txtIPAddress($tframe->Entry(-width => 15,
143 -background => 'white',
144 -textvariable => \$self->{selIPAddress}, # variable holds the contents of the widget
145 )->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x'));
146
147 my $btnContinue = $bframe->Button(-text => "Begin with these settings",
148 - command =>sub {
149 my $success = $self->GenerateQueryScreen($context);
150 unless ($success){
151 $self->GenerateErrorMessage("failed to create full connection with these parameters");
152 }
153 }
154 )->pack(-side => 'bottom');
155
156 foreach my $source(@{$self->DATA_SOURCES}){
157 my ($name, $cfg) = @{$source};
158 $self->lbxDataSource->insert(1,$name); # add to the BrowseEntry widget
159 }
160 $self->lbxDataSource->pack(-side => 'top', -anchor => 'w', -expand => 1, -fill => 'x');
161
162 $ttframe->pack(-side => 'top', -expand => 1, -fill => 'both');
163 $tframe->pack(-side => 'top', -expand => 1, -fill => 'both');
164 $bframe->pack(-side => 'bottom', -fill => 'x');
165
166 return 1;
167
168 }
169
170 sub attemptConnection {
171 my ($self) = @_;
172 my $source = $self->{selDataSource}; # get the item from the encapsulated ref bound to the listbox
173
174 foreach my $sources(@{$self->DATA_SOURCES}){
175 my ($known, $cfg) = @{$sources};
176 if ($known eq $source){
177 do $cfg;
178 }
179 }
180 unless ($context) { #the context object contains all stuff, including a list of organisms
181 return 0;
182 }
183
184 # do various housekeeping things here
185 # like updating the organisms box, ip address box
186 # based on what was returned from the config file
187 $self->{selFilename} = $Filename;
188 $self->{selUsername} = $Username;
189 $self->{selPassword} = $Password;
190 $self->{selIPAddress} = $IPAddress;
191 #print "deleting organisms\n";
192 $self->lbxOrganism->delete(0, 1000);
193 foreach my $org($context->all_orgs_by_id){
194 next unless $org->common;
195 #print "found ",$org->common,"\n";
196 $self->lbxOrganism->insert(1, $org->common); # add to the BrowseEntry widget
197 $self->{selOrganism} = $org->common; # update the visible contents of the widget
198 }
199 # make sure the fields enabled/disabled as required, etc.etc.
200
201 return $context; # say that a connection can, in principle, happen
202 }
203
204 sub GenerateQueryScreen {
205 my ($self,$context) = @_;
206
207 foreach my $org($context->all_orgs_by_id){
208 if ($self->{selOrganism} eq $org->common){
209 $context->organism($org);
210 }
211 }
212 return 0 unless ($context->organism->latin);
213
214 my $QS = GQ::Client::QueryScreen->new(
215 $self->toplevel,
216 context => $context,
217 TEMP_DIR => $self->TEMP_DIR,
218 WORKING_DIR => $self->WORKING_DIR,
219 PLUGINS_DIR => $self->PLUGINS_DIR,
220 BLAST_URL => $self->BLAST_URL,
221 BLAST_CONFIG => $self->BLAST_CONFIG,
222 BROWSER => $self->BROWSER,
223 );
224 $self->QS($QS);
225 return $QS;
226 }
227
228 sub GenerateErrorMessage {
229 my ($self, $message) = @_;
230 my $top = $self->top;
231 my $return = $top->DialogBox(-title => "Error");
232 $return->add("Label", -text => $message)->pack;
233 $return->Show;
234 }
235
236 sub AUTOLOAD {
237 no strict "refs";
238 my ($self, $newval) = @_;
239
240 $AUTOLOAD =~ /.*::(\w+)/;
241
242 my $attr=$1;
243 if ($self->_accessible($attr,'write')) {
244
245 *{$AUTOLOAD} = sub {
246 if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
247 return $_[0]->{$attr};
248 }; ### end of created subroutine
249
250 ### this is called first time only
251 if (defined $newval) {
252 $self->{$attr} = $newval
253 }
254 return $self->{$attr};
255
256 } elsif ($self->_accessible($attr,'read')) {
257
258 *{$AUTOLOAD} = sub {
259 return $_[0]->{$attr} }; ### end of created subroutine
260 return $self->{$attr} }
261
262
263 # Must have been a mistake then...
264 croak "No such method: $AUTOLOAD";
265 }
266
267 1;