cqtool/CreateWORUI.pm

   1 ##############################################################################
   2 #
   3 # Name: CreateWORUI.pm
   4 #
   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.
  14 #
  15 #              Another problem is that while IBM/Rational's cqtool
  16 #              would work, it does not return the ID of the WOR
  17 #              created!
  18 #
  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.
  25 #
  26 # Author: Andrew@ClearSCM.com
  27 #
  28 # (c) Copyright 2007, General Dynamics, all rights reserved
  29 #
  30 ##############################################################################
  31 use strict;
  32 use warnings;
  33
  34 package CreateWORUI;
  35   use Tk;
  36   use Tk::Dialog;
  37   use Tk::MyText;
  38
  39   use Display;
  40   use CQTool;
  41
  42   use base "Exporter";
  43
  44   my $ME                = "CreateWOR";
  45   my $VERSION           = "1.1";
  46
  47   # Colors
  48   my ($EDIT_FOREGROUND, $EDIT_BACKGROUND);
  49
  50   our %wor;
  51
  52   our @EXPORT = qw (
  53     createWORUI
  54     %wor
  55   );
  56
  57   # Globals
  58   my $_createWORUI;
  59
  60   # Dropdowns
  61   my (
  62     $_projects,
  63     $_rclcs,
  64     $_prod_arch1s,
  65     $_prod_arch2s,
  66     $_engr_targets,
  67     $_work_codes,
  68     $_work_products,
  69     $_wor_classes,
  70   );
  71
  72   # Choice lists
  73   my (
  74     @_projects,
  75     @_rclcs,
  76     @_prod_arch1s,
  77     @_prod_arch2s,
  78     @_engr_targets,
  79     @_work_codes,
  80     @_work_products,
  81     @_wor_classes,
  82   );
  83
  84   # Buttons
  85   my $_submit;
  86
  87   ############################################################################
  88   # Subroutines
  89   ############################################################################
  90
  91   #---------------------------------------------------------------------------
  92   # _helpAbout (): Puts up the Help: About dialog box
  93   #---------------------------------------------------------------------------
  94   sub _helpAbout () {
  95     my $text = "$ME v$VERSION\n";
  96
  97     $text .= <<END;
  98
  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.
 100
 101 Copyright General Dynamics © 2007 - All rights reserved
 102 Developed by Andrew DeFaria <Andrew\@ClearSCM.com> of ClearSCM, Inc.
 103 END
 104
 105     my $desc = $_createWORUI->Dialog (
 106       -title            => "About $ME",
 107       -text             => $text,
 108       -buttons          => [ "OK" ],
 109     );
 110
 111     $desc->Show ();
 112   } # _helpAbout
 113
 114   #---------------------------------------------------------------------------
 115   # _displayValues (): Displays the contents for %wor hash
 116   #---------------------------------------------------------------------------
 117   sub _displayValues () {
 118     foreach (keys %wor) {
 119       if ($wor{$_}) {
 120         display ("$_: $wor{$_}");
 121       } else {
 122         display ("$_: undef");
 123       } # if
 124     } # foreach
 125   } # _displayValues
 126
 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) = @_;
 133
 134     return @{$entity->GetFieldChoiceList ($fieldname)};
 135   } # _getChoices
 136
 137   #---------------------------------------------------------------------------
 138   # _destroyCreateWORUI (): Destroys the current WOR UI recycling Tk objects
 139   #---------------------------------------------------------------------------
 140   sub _destroyCreateWORUI () {
 141     # Destroy all globals created
 142     destroy $_submit;
 143     destroy $_projects;
 144     destroy $_rclcs;
 145     destroy $_prod_arch1s;
 146     destroy $_prod_arch2s;
 147     destroy $_engr_targets;
 148     destroy $_work_codes;
 149     destroy $_work_products;
 150     destroy $_createWORUI;
 151
 152     $_submit            =
 153     $_projects          =
 154     $_rclcs             =
 155     $_prod_arch1s       =
 156     $_prod_arch2s       =
 157     $_engr_targets      =
 158     $_work_codes        =
 159     $_work_products     =
 160     $_wor_classes       =
 161     $_createWORUI       = undef;
 162
 163     %wor = ();
 164   } # _destroyCreateWORUI
 165
 166   #---------------------------------------------------------------------------
 167   # _submit (): Actually creates the WOR given the filled out %wor hash.
 168   #---------------------------------------------------------------------------
 169   sub _submit () {
 170     debug "Creating WOR...";
 171     _displayValues if get_debug;
 172     my $new_id = CQTool::submitWOR ($CQTool::entity, %wor);
 173
 174     display ($new_id) if $new_id;
 175
 176     _destroyCreateWORUI;
 177
 178     return $new_id;
 179   } # _submit
 180
 181   #---------------------------------------------------------------------------
 182   # _setSubmitButton (): Sets the submit button to active only if all required
 183   #                      fields have values.
 184   #---------------------------------------------------------------------------
 185   sub _setSubmitButton (;$) {
 186     my ($headline) = @_;
 187
 188     return if !$_submit;
 189
 190     # Check to see if we can activate the submit button
 191     my $state = "normal";
 192
 193     foreach (@CQTool::wor_required_fields) {
 194       if ($_ eq "headline") {
 195         if (defined $headline) {
 196           if ($headline eq "") {
 197             $state = "disable";
 198             last;
 199           } else {
 200             next;
 201           } # if
 202         } # if
 203       } # if
 204
 205       if (!$wor{$_} or $wor{$_} eq "") {
 206         $state = "disable";
 207         last;
 208       } # if
 209     } # foreach
 210
 211     $_submit->configure (
 212       -state    => $state,
 213     );
 214   } # _setSubmitButton
 215
 216   #---------------------------------------------------------------------------
 217   # _validateText (): Gets the text from the MyText widget and sets the submit
 218   #                   button
 219   #---------------------------------------------------------------------------
 220   sub _validateText {
 221     my ($text) = @_;
 222
 223     $wor{description} = $text->get_text;
 224     chomp $wor{description};
 225
 226     _setSubmitButton $text;
 227
 228     return 1;
 229   } # _validateText
 230
 231   #---------------------------------------------------------------------------
 232   # _validateEntry (): Gets the text from the headline widget and sets the
 233   #                    submit button
 234   #---------------------------------------------------------------------------
 235   sub _validateEntry {
 236     my ($entry) = @_;
 237
 238     _setSubmitButton $entry;
 239
 240     return 1;
 241   } # _validateEntry
 242
 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) = @_;
 250
 251     $parent->Label (
 252       -width            => length $label,
 253       -text             => "$label:",
 254     )->grid (
 255       -row              => $x,
 256       -column           => $y,
 257       -sticky           => "e",
 258     );
 259
 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,
 265       -variable         => $value,
 266       -options          => \@values,
 267     )->grid (
 268       -row              => $x,
 269       -column           => $y + 1,
 270       -sticky           => "w",
 271     );
 272   } # _createDropDown
 273
 274   #---------------------------------------------------------------------------
 275   # _createTextField (): Creates a text field widget in $parent with a $label
 276   #                      and a $value, using a $maxlen and a $validate
 277   #                      procedure.
 278   #---------------------------------------------------------------------------
 279   sub _createTextField ($$$$$) {
 280     my ($parent, $label, $value, $maxlen, $validate) = @_;
 281
 282     $parent->Label (
 283       -text             => "$label:",
 284       -justify          => "right",
 285       -width            => 10,
 286     )->pack (
 287       -side             => "left",
 288       -anchor           => "e",
 289     );
 290
 291     $parent->Entry (
 292       -foreground       => $EDIT_FOREGROUND,
 293       -background       => $EDIT_BACKGROUND,
 294       -width            => $maxlen,
 295       -justify          => "left",
 296       -textvariable     => $value,
 297       -validate         => "key",
 298       -validatecommand  => \&$validate,
 299     )->pack (
 300       -side             => "left",
 301       -padx             => 5,
 302       -anchor           => "e",
 303     );
 304   } # _createTextField
 305
 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) = @_;
 313
 314     $parent->Label (
 315       -text             => "$label:",
 316       -justify          => "right",
 317       -width            => 10,
 318     )->pack (
 319       -side             => "left",+
 320       -anchor           => "n",
 321       -pady             => 5,
 322     );
 323
 324     $parent->MyText (
 325       -foreground       => $EDIT_FOREGROUND,
 326       -background       => $EDIT_BACKGROUND,
 327       -height           => $rows,
 328       -width            => $cols,
 329       -modified         => \&$validate,
 330       -text             => $value,
 331     )->pack (
 332       -side             => "left",
 333       -pady             => 5,
 334       -anchor           => "s",
 335     );
 336   } # _createText
 337
 338   #---------------------------------------------------------------------------
 339   # _createButton (): Creates a pushbutton widget in $parent with a $label and
 340   #                   an $action.
 341   #---------------------------------------------------------------------------
 342   sub _createButton ($$$) {
 343     my ($parent, $label, $action) = @_;
 344
 345     $parent->Button (
 346       -activeforeground => $EDIT_FOREGROUND,
 347       -activebackground => $EDIT_BACKGROUND,
 348       -text             => $label,
 349       -width            => length $label,
 350       -command          => \$action
 351     )->pack (
 352       -side             => "left",
 353       -padx             => 5
 354     );
 355   } # _createButton
 356
 357   #---------------------------------------------------------------------------
 358   # _changeDropDown (): Refreshes the values in the dropdown menu.
 359   #---------------------------------------------------------------------------
 360   sub _changeDropDown ($@) {
 361     my ($dropdown, @values) = @_;
 362
 363     if ($dropdown) {
 364       my $menu = $dropdown->menu;
 365
 366       if ($menu) {
 367         $dropdown->menu->delete (0, "end");
 368       } # if
 369
 370       $dropdown->addOptions (@values);
 371     } # if
 372   } # _changeDropDown
 373
 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   #---------------------------------------------------------------------------
 379   sub _refresh () {
 380     my $fieldname;
 381
 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});
 386
 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});
 391
 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});
 396
 397     $fieldname          = "rclc_name";
 398     @_rclcs             = @{$projects{$wor{project}}};
 399     $wor{$fieldname}    = $_rclcs[0] if !$wor{$fieldname};
 400     $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
 401
 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});
 406
 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});
 411
 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});
 416
 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);
 424
 425     _setSubmitButton ();
 426   } # _refresh
 427
 428   #---------------------------------------------------------------------------
 429   # _darken (): Returns a slightly darker color than the passed in color
 430   #---------------------------------------------------------------------------
 431   sub _darken ($) {
 432     my ($color) = @_;
 433
 434     # Get the RGB values
 435     my ($r, $g, $b) = $_createWORUI->rgb($color);
 436
 437     # Set them to $DARKEN % of their previous values
 438     my $DARKEN = .8;
 439     my $rhex = sprintf "%x", $r * $DARKEN;
 440     my $ghex = sprintf "%x", $g * $DARKEN;
 441     my $bhex = sprintf "%x", $b * $DARKEN;
 442
 443     # Return a color string
 444     return "\#$rhex$ghex$bhex";
 445   } # _darken
 446
 447   #---------------------------------------------------------------------------
 448   # createWORUI (): This is the main and exported routine that creates and
 449   #                 handles the entire Perl/Tk application for creating a
 450   #                 WOR.
 451   #---------------------------------------------------------------------------
 452   sub createWORUI () {
 453     $_createWORUI = MainWindow->new;
 454
 455     $EDIT_FOREGROUND    = $_createWORUI->optionGet ("foreground", "Foreground");
 456     $EDIT_BACKGROUND    = _darken ($_createWORUI->optionGet ("background", "Background"));
 457
 458     $wor{id} = "None" if !$wor{id};
 459
 460     $_createWORUI->title ("Submit WOR $wor{id}");
 461
 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;
 467
 468     _createTextField (
 469       $frame1,
 470       "Headline",
 471       \$wor{headline},
 472       100,
 473       \&_validateEntry
 474     );
 475
 476     _createText (
 477       $frame2,
 478       "Description",
 479       \$wor{description},
 480       24, 100,
 481       \&_validateText
 482     );
 483
 484     my %projects = CQTool::getProjects ($CQTool::session);
 485     @_projects = keys %projects;
 486
 487     $_projects = _createDropDown (
 488       $frame3,
 489       0, 0,
 490       "Project",
 491       \&_refresh,
 492       \$wor{project},
 493       @_projects
 494     );
 495     $_rclcs = _createDropDown (
 496       $frame3,
 497       0, 3,
 498       "Revision Control Life Cycle",
 499       \&_refresh,
 500       \$wor{rclc_name},
 501       @_rclcs
 502     );
 503
 504     $_prod_arch1s = _createDropDown (
 505       $frame3,
 506       2, 0,
 507       "Product Architecture 1",
 508       \&_refresh,
 509       \$wor{prod_arch1},
 510       @_prod_arch1s
 511     );
 512     $_engr_targets = _createDropDown (
 513       $frame3,
 514       2, 3,
 515       "Engineering Target",
 516       \&_refresh,
 517       \$wor{engr_target},
 518       @_engr_targets
 519     );
 520
 521     $_prod_arch2s = _createDropDown (
 522       $frame3,
 523       4, 0,
 524       "Product Architecture 2",
 525       \&_refresh,
 526       \$wor{prod_arch2},
 527       @_prod_arch2s
 528     );
 529     $_work_codes = _createDropDown (
 530       $frame3,
 531       4, 3,
 532       "Work Code",
 533       \&_refresh,
 534       \$wor{work_code_name},
 535       @_work_codes
 536     );
 537
 538     $_work_products = _createDropDown (
 539       $frame3,
 540       6, 0,
 541       "Work Product",
 542       \&_refresh,
 543       \$wor{work_product_name},
 544       @_work_products
 545     );
 546
 547     my $fieldname       = "wor_class";
 548     @_wor_classes       = _getChoices $CQTool::entity, $fieldname;
 549     $wor{$fieldname}    = "Worker";
 550     $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
 551
 552     $_wor_classes = _createDropDown (
 553       $frame3,
 554       6, 3,
 555       "WOR Class",
 556       sub {},
 557       \$wor{wor_class},
 558       @_wor_classes
 559     );
 560
 561     # Default WOR Class to Worker
 562     $_wor_classes->setOption ("Worker");
 563
 564     $_submit = _createButton ($frame4, "Submit", \&_submit);
 565
 566     $_submit->configure (
 567       -state    => "disabled",
 568     );
 569
 570     _createButton ($frame4, "Display",  \&_displayValues) if (get_debug);
 571     _createButton ($frame4, "About",    \&_helpAbout);
 572     _createButton ($frame4, "Exit",     \&_destroyCreateWORUI);
 573   } # createWORUI
 574
 575 1;