1 ##############################################################################
5 # Description: CreateWORUI.pm is a Perl module that encapsulates a
6 # Perl/Tk application to create a WOR. This application
7 # was developed for a few reasons. First ucmwb needs to
8 # be able to create WORs. The approach was to use
9 # IBM/Rational's cqtool
10 # (/opt/rational/clearquest/bin/cqtool) but there is two
11 # problems with this. First IBM/Rational's cqtool is
12 # unsupported and documented. Secondly IBM/Rational's
13 # cqtool is going away as of Clearquest 7.0.
15 # Another problem is that while IBM/Rational's cqtool
16 # would work, it does not return the ID of the WOR
19 # So this Perl/Tk module was created to create WORs. Perl
20 # interfaces with Clearquest to call the appropraite
21 # Clearquest action hooks and the like. Note that only
22 # the basic information is asked for. If you really want
23 # to create or modify a full WOR use Clearquest. This
24 # Perl/Tk app's main customer is ucmwb.
26 # Author: Andrew@ClearSCM.com
28 # (c) Copyright 2007, General Dynamics, all rights reserved
30 ##############################################################################
48 my ($EDIT_FOREGROUND, $EDIT_BACKGROUND);
87 ############################################################################
89 ############################################################################
91 #---------------------------------------------------------------------------
92 # _helpAbout (): Puts up the Help: About dialog box
93 #---------------------------------------------------------------------------
95 my $text = "$ME v$VERSION\n";
99 This application creates a WOR using Perl/Tk. It is used by UCM/WB or can be used stand alone. It effectively replicates the functionality of Clearquest but 1) is blocking and 2) returns the RANCQ # so that UCM/WB can determine the number of the newly created WOR.
101 Copyright General Dynamics © 2007 - All rights reserved
102 Developed by Andrew DeFaria <Andrew\@ClearSCM.com> of ClearSCM, Inc.
105 my $desc = $_createWORUI->Dialog (
106 -title => "About $ME",
108 -buttons => [ "OK" ],
114 #---------------------------------------------------------------------------
115 # _displayValues (): Displays the contents for %wor hash
116 #---------------------------------------------------------------------------
117 sub _displayValues () {
118 foreach (keys %wor) {
120 display ("$_: $wor{$_}");
122 display ("$_: undef");
127 #---------------------------------------------------------------------------
128 # _getChoices (): For a given $entity and $fieldname, this routine returns
129 # the given choice list from Clearquest.
130 #---------------------------------------------------------------------------
131 sub _getChoices ($$) {
132 my ($entity, $fieldname) = @_;
134 return @{$entity->GetFieldChoiceList ($fieldname)};
137 #---------------------------------------------------------------------------
138 # _destroyCreateWORUI (): Destroys the current WOR UI recycling Tk objects
139 #---------------------------------------------------------------------------
140 sub _destroyCreateWORUI () {
141 # Destroy all globals created
145 destroy $_prod_arch1s;
146 destroy $_prod_arch2s;
147 destroy $_engr_targets;
148 destroy $_work_codes;
149 destroy $_work_products;
150 destroy $_createWORUI;
161 $_createWORUI = undef;
164 } # _destroyCreateWORUI
166 #---------------------------------------------------------------------------
167 # _submit (): Actually creates the WOR given the filled out %wor hash.
168 #---------------------------------------------------------------------------
170 debug "Creating WOR...";
171 _displayValues if get_debug;
172 my $new_id = CQTool::submitWOR ($CQTool::entity, %wor);
174 display ($new_id) if $new_id;
181 #---------------------------------------------------------------------------
182 # _setSubmitButton (): Sets the submit button to active only if all required
183 # fields have values.
184 #---------------------------------------------------------------------------
185 sub _setSubmitButton (;$) {
190 # Check to see if we can activate the submit button
191 my $state = "normal";
193 foreach (@CQTool::wor_required_fields) {
194 if ($_ eq "headline") {
195 if (defined $headline) {
196 if ($headline eq "") {
205 if (!$wor{$_} or $wor{$_} eq "") {
211 $_submit->configure (
216 #---------------------------------------------------------------------------
217 # _validateText (): Gets the text from the MyText widget and sets the submit
219 #---------------------------------------------------------------------------
223 $wor{description} = $text->get_text;
224 chomp $wor{description};
226 _setSubmitButton $text;
231 #---------------------------------------------------------------------------
232 # _validateEntry (): Gets the text from the headline widget and sets the
234 #---------------------------------------------------------------------------
238 _setSubmitButton $entry;
243 #---------------------------------------------------------------------------
244 # _createDropDown (): Creates a dropdown widget in $parent in a grid at the
245 # $x, $y coordinates with a $label and a $value, using
246 # dropdown @values and a $refresh procedure.
247 #---------------------------------------------------------------------------
248 sub _createDropDown ($$$$$$@) {
249 my ($parent, $x, $y, $label, $refresh, $value, @values) = @_;
252 -width => length $label,
260 # Color the active foreground otherwise it's defaulted to ugly grey!
261 return $parent->Optionmenu (
262 -activeforeground => $EDIT_FOREGROUND,
263 -activebackground => $EDIT_BACKGROUND,
264 -command => \&$refresh,
266 -options => \@values,
274 #---------------------------------------------------------------------------
275 # _createTextField (): Creates a text field widget in $parent with a $label
276 # and a $value, using a $maxlen and a $validate
278 #---------------------------------------------------------------------------
279 sub _createTextField ($$$$$) {
280 my ($parent, $label, $value, $maxlen, $validate) = @_;
292 -foreground => $EDIT_FOREGROUND,
293 -background => $EDIT_BACKGROUND,
296 -textvariable => $value,
298 -validatecommand => \&$validate,
306 #---------------------------------------------------------------------------
307 # _createText (): Creates a multiline text field widget in $parent with a
308 # $label and a $value, using the specified $rows and $cols
309 # and a $validate procedure.
310 #---------------------------------------------------------------------------
311 sub _createText ($$$$$$) {
312 my ($parent, $label, $value, $rows, $cols, $validate) = @_;
325 -foreground => $EDIT_FOREGROUND,
326 -background => $EDIT_BACKGROUND,
329 -modified => \&$validate,
338 #---------------------------------------------------------------------------
339 # _createButton (): Creates a pushbutton widget in $parent with a $label and
341 #---------------------------------------------------------------------------
342 sub _createButton ($$$) {
343 my ($parent, $label, $action) = @_;
346 -activeforeground => $EDIT_FOREGROUND,
347 -activebackground => $EDIT_BACKGROUND,
349 -width => length $label,
357 #---------------------------------------------------------------------------
358 # _changeDropDown (): Refreshes the values in the dropdown menu.
359 #---------------------------------------------------------------------------
360 sub _changeDropDown ($@) {
361 my ($dropdown, @values) = @_;
364 my $menu = $dropdown->menu;
367 $dropdown->menu->delete (0, "end");
370 $dropdown->addOptions (@values);
374 #---------------------------------------------------------------------------
375 # _refresh (): Refreshes the application by getting news values from
376 # Clearquest. Note a change in one dropdown may change others,
377 # so we re-get all of them through this procedure.
378 #---------------------------------------------------------------------------
382 $fieldname = "project";
383 my %projects = CQTool::getProjects $CQTool::session;
384 $wor{$fieldname} = $_projects[0] if !$wor{fieldname};
385 $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
387 $fieldname = "prod_arch1";
388 @_prod_arch1s = _getChoices $CQTool::entity, $fieldname;
389 $wor{$fieldname} = $_prod_arch1s[0] if !$wor{$fieldname};
390 $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
392 $fieldname = "prod_arch2";
393 @_prod_arch2s = _getChoices $CQTool::entity, $fieldname;
394 $wor{$fieldname} = $_prod_arch2s[0] if !$wor{$fieldname};
395 $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
397 $fieldname = "rclc_name";
398 @_rclcs = @{$projects{$wor{project}}};
399 $wor{$fieldname} = $_rclcs[0] if !$wor{$fieldname};
400 $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
402 $fieldname = "engr_target";
403 @_engr_targets = _getChoices $CQTool::entity, $fieldname;
404 $wor{$fieldname} = $_engr_targets[0] if !$wor{$fieldname};
405 $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
407 $fieldname = "work_code_name";
408 @_work_codes = _getChoices $CQTool::entity, $fieldname;
409 $wor{$fieldname} = $_work_codes[0] if !$wor{$fieldname};
410 $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
412 $fieldname = "work_product_name";
413 @_work_products = _getChoices $CQTool::entity, $fieldname;
414 $wor{$fieldname} = $_work_products[0] if !$wor{$fieldname};
415 $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
417 _changeDropDown ($_projects, keys %projects);
418 _changeDropDown ($_rclcs, @_rclcs);
419 _changeDropDown ($_prod_arch1s, @_prod_arch1s);
420 _changeDropDown ($_prod_arch2s, @_prod_arch2s);
421 _changeDropDown ($_engr_targets, @_engr_targets);
422 _changeDropDown ($_work_codes, @_work_codes);
423 _changeDropDown ($_work_products, @_work_products);
428 #---------------------------------------------------------------------------
429 # _darken (): Returns a slightly darker color than the passed in color
430 #---------------------------------------------------------------------------
435 my ($r, $g, $b) = $_createWORUI->rgb($color);
437 # Set them to $DARKEN % of their previous values
439 my $rhex = sprintf "%x", $r * $DARKEN;
440 my $ghex = sprintf "%x", $g * $DARKEN;
441 my $bhex = sprintf "%x", $b * $DARKEN;
443 # Return a color string
444 return "\#$rhex$ghex$bhex";
447 #---------------------------------------------------------------------------
448 # createWORUI (): This is the main and exported routine that creates and
449 # handles the entire Perl/Tk application for creating a
451 #---------------------------------------------------------------------------
453 $_createWORUI = MainWindow->new;
455 $EDIT_FOREGROUND = $_createWORUI->optionGet ("foreground", "Foreground");
456 $EDIT_BACKGROUND = _darken ($_createWORUI->optionGet ("background", "Background"));
458 $wor{id} = "None" if !$wor{id};
460 $_createWORUI->title ("Submit WOR $wor{id}");
462 my $frame0 = $_createWORUI->Frame->pack (-pady => 2);
463 my $frame1 = $_createWORUI->Frame->pack;
464 my $frame2 = $_createWORUI->Frame->pack;
465 my $frame3 = $_createWORUI->Frame->pack;
466 my $frame4 = $_createWORUI->Frame->pack;
484 my %projects = CQTool::getProjects ($CQTool::session);
485 @_projects = keys %projects;
487 $_projects = _createDropDown (
495 $_rclcs = _createDropDown (
498 "Revision Control Life Cycle",
504 $_prod_arch1s = _createDropDown (
507 "Product Architecture 1",
512 $_engr_targets = _createDropDown (
515 "Engineering Target",
521 $_prod_arch2s = _createDropDown (
524 "Product Architecture 2",
529 $_work_codes = _createDropDown (
534 \$wor{work_code_name},
538 $_work_products = _createDropDown (
543 \$wor{work_product_name},
547 my $fieldname = "wor_class";
548 @_wor_classes = _getChoices $CQTool::entity, $fieldname;
549 $wor{$fieldname} = "Worker";
550 $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
552 $_wor_classes = _createDropDown (
561 # Default WOR Class to Worker
562 $_wor_classes->setOption ("Worker");
564 $_submit = _createButton ($frame4, "Submit", \&_submit);
566 $_submit->configure (
567 -state => "disabled",
570 _createButton ($frame4, "Display", \&_displayValues) if (get_debug);
571 _createButton ($frame4, "About", \&_helpAbout);
572 _createButton ($frame4, "Exit", \&_destroyCreateWORUI);