X-Git-Url: https://defaria.com/gitweb/?a=blobdiff_plain;f=clients%2FGD%2Fcqtool%2FCreateWORUI.pm;fp=clients%2FGD%2Fcqtool%2FCreateWORUI.pm;h=8a62a86d06f1a36de73df54d3758d0f4c9384999;hb=a8c84d2892f07a6863b68a11eb0a4a79ffd71fb5;hp=0000000000000000000000000000000000000000;hpb=95384f94f88aceeb5eef2d322210ba4a438b6512;p=clearscm.git

diff --git a/clients/GD/cqtool/CreateWORUI.pm b/clients/GD/cqtool/CreateWORUI.pm
new file mode 100644
index 0000000..8a62a86
--- /dev/null
+++ b/clients/GD/cqtool/CreateWORUI.pm
@@ -0,0 +1,575 @@
+##############################################################################
+#
+# Name: CreateWORUI.pm
+#
+# Description: CreateWORUI.pm is a Perl module that encapsulates a
+#	       Perl/Tk application to create a WOR. This application
+#	       was developed for a few reasons. First ucmwb needs to
+#	       be able to create WORs. The approach was to use
+#	       IBM/Rational's cqtool
+#	       (/opt/rational/clearquest/bin/cqtool) but there is two
+#	       problems with this. First IBM/Rational's cqtool is
+#	       unsupported and documented. Secondly IBM/Rational's
+#	       cqtool is going away as of Clearquest 7.0.
+#
+#	       Another problem is that while IBM/Rational's cqtool
+#	       would work, it does not return the ID of the WOR
+#	       created!
+#
+#	       So this Perl/Tk module was created to create WORs. Perl
+#	       interfaces with Clearquest to call the appropraite
+#	       Clearquest action hooks and the like. Note that only
+#	       the basic information is asked for. If you really want
+#	       to create or modify a full WOR use Clearquest. This
+#	       Perl/Tk app's main customer is ucmwb.
+#
+# Author: Andrew@ClearSCM.com
+#
+# (c) Copyright 2007, General Dynamics, all rights reserved
+#
+##############################################################################
+use strict;
+use warnings;
+
+package CreateWORUI;
+  use Tk;
+  use Tk::Dialog;
+  use Tk::MyText;
+
+  use Display;
+  use CQTool;
+
+  use base "Exporter";
+
+  my $ME		= "CreateWOR";
+  my $VERSION		= "1.1";
+
+  # Colors
+  my ($EDIT_FOREGROUND, $EDIT_BACKGROUND);
+
+  our %wor;
+
+  our @EXPORT = qw (
+    createWORUI
+    %wor
+  );
+
+  # Globals
+  my $_createWORUI;
+
+  # Dropdowns
+  my (
+    $_projects,
+    $_rclcs,
+    $_prod_arch1s,
+    $_prod_arch2s,
+    $_engr_targets,
+    $_work_codes,
+    $_work_products,
+    $_wor_classes,
+  );
+
+  # Choice lists
+  my (
+    @_projects,
+    @_rclcs,
+    @_prod_arch1s,
+    @_prod_arch2s,
+    @_engr_targets,
+    @_work_codes,
+    @_work_products,
+    @_wor_classes,
+  );
+
+  # Buttons
+  my $_submit;
+
+  ############################################################################
+  # Subroutines
+  ############################################################################
+
+  #---------------------------------------------------------------------------
+  # _helpAbout (): Puts up the Help: About dialog box
+  #---------------------------------------------------------------------------
+  sub _helpAbout () {
+    my $text = "$ME v$VERSION\n";
+
+    $text .= <<END;
+
+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.
+
+Copyright General Dynamics © 2007 - All rights reserved
+Developed by Andrew DeFaria <Andrew\@ClearSCM.com> of ClearSCM, Inc.
+END
+
+    my $desc = $_createWORUI->Dialog (
+      -title		=> "About $ME",
+      -text		=> $text,
+      -buttons		=> [ "OK" ],
+    );
+
+    $desc->Show ();
+  } # _helpAbout
+
+  #---------------------------------------------------------------------------
+  # _displayValues (): Displays the contents for %wor hash
+  #---------------------------------------------------------------------------
+  sub _displayValues () {
+    foreach (keys %wor) {
+      if ($wor{$_}) {
+        display ("$_: $wor{$_}");
+      } else {
+        display ("$_: undef");
+      } # if
+    } # foreach
+  } # _displayValues
+
+  #---------------------------------------------------------------------------
+  # _getChoices (): For a given $entity and $fieldname, this routine returns
+  #		    the given choice list from Clearquest.
+  #---------------------------------------------------------------------------
+  sub _getChoices ($$) {
+    my ($entity, $fieldname) = @_;
+
+    return @{$entity->GetFieldChoiceList ($fieldname)};
+  } # _getChoices
+
+  #---------------------------------------------------------------------------
+  # _destroyCreateWORUI (): Destroys the current WOR UI recycling Tk objects
+  #---------------------------------------------------------------------------
+  sub _destroyCreateWORUI () {
+    # Destroy all globals created
+    destroy $_submit;
+    destroy $_projects;
+    destroy $_rclcs;
+    destroy $_prod_arch1s;
+    destroy $_prod_arch2s;
+    destroy $_engr_targets;
+    destroy $_work_codes;
+    destroy $_work_products;
+    destroy $_createWORUI;
+
+    $_submit		=
+    $_projects		=
+    $_rclcs		=
+    $_prod_arch1s	=
+    $_prod_arch2s	=
+    $_engr_targets	=
+    $_work_codes	=
+    $_work_products	=
+    $_wor_classes	=
+    $_createWORUI	= undef;
+
+    %wor = ();
+  } # _destroyCreateWORUI
+
+  #---------------------------------------------------------------------------
+  # _submit (): Actually creates the WOR given the filled out %wor hash.
+  #---------------------------------------------------------------------------
+  sub _submit () {
+    debug "Creating WOR...";
+    _displayValues if get_debug;
+    my $new_id = CQTool::submitWOR ($CQTool::entity, %wor);
+
+    display ($new_id) if $new_id;
+
+    _destroyCreateWORUI;
+
+    return $new_id;
+  } # _submit
+
+  #---------------------------------------------------------------------------
+  # _setSubmitButton (): Sets the submit button to active only if all required
+  #			 fields have values.
+  #---------------------------------------------------------------------------
+  sub _setSubmitButton (;$) {
+    my ($headline) = @_;
+
+    return if !$_submit;
+
+    # Check to see if we can activate the submit button
+    my $state = "normal";
+
+    foreach (@CQTool::wor_required_fields) {
+      if ($_ eq "headline") {
+        if (defined $headline) {
+	  if ($headline eq "") {
+	    $state = "disable";
+	    last;
+	  } else {
+	    next;
+	  } # if
+	} # if
+      } # if
+
+      if (!$wor{$_} or $wor{$_} eq "") {
+	$state = "disable";
+	last;
+      } # if
+    } # foreach
+
+    $_submit->configure (
+      -state	=> $state,
+    );
+  } # _setSubmitButton
+
+  #---------------------------------------------------------------------------
+  # _validateText (): Gets the text from the MyText widget and sets the submit
+  #		      button
+  #---------------------------------------------------------------------------
+  sub _validateText {
+    my ($text) = @_;
+
+    $wor{description} = $text->get_text;
+    chomp $wor{description};
+
+    _setSubmitButton $text;
+
+    return 1;
+  } # _validateText
+
+  #---------------------------------------------------------------------------
+  # _validateEntry (): Gets the text from the headline widget and sets the
+  # 		       submit button
+  #---------------------------------------------------------------------------
+  sub _validateEntry {
+    my ($entry) = @_;
+
+    _setSubmitButton $entry;
+
+    return 1;
+  } # _validateEntry
+
+  #---------------------------------------------------------------------------
+  # _createDropDown (): Creates a dropdown widget in $parent in a grid at the
+  #			$x, $y coordinates with a $label and a $value, using
+  #			dropdown @values and a $refresh procedure.
+  #---------------------------------------------------------------------------
+  sub _createDropDown ($$$$$$@) {
+    my ($parent, $x, $y, $label, $refresh, $value, @values) = @_;
+
+    $parent->Label (
+      -width		=> length $label,
+      -text		=> "$label:",
+    )->grid (
+      -row		=> $x,
+      -column		=> $y,
+      -sticky		=> "e",
+    );
+
+    # Color the active foreground otherwise it's defaulted to ugly grey!
+    return $parent->Optionmenu (
+      -activeforeground	=> $EDIT_FOREGROUND,
+      -activebackground	=> $EDIT_BACKGROUND,
+      -command		=> \&$refresh,
+      -variable		=> $value,
+      -options		=> \@values,
+    )->grid (
+      -row		=> $x,
+      -column		=> $y + 1,
+      -sticky		=> "w",
+    );
+  } # _createDropDown
+
+  #---------------------------------------------------------------------------
+  # _createTextField (): Creates a text field widget in $parent with a $label
+  #			 and a $value, using a $maxlen and a $validate
+  #			 procedure.
+  #---------------------------------------------------------------------------
+  sub _createTextField ($$$$$) {
+    my ($parent, $label, $value, $maxlen, $validate) = @_;
+
+    $parent->Label (
+      -text		=> "$label:",
+      -justify		=> "right",
+      -width		=> 10,
+    )->pack (
+      -side		=> "left",
+      -anchor		=> "e",
+    );
+
+    $parent->Entry (
+      -foreground	=> $EDIT_FOREGROUND,
+      -background	=> $EDIT_BACKGROUND,
+      -width		=> $maxlen,
+      -justify		=> "left",
+      -textvariable	=> $value,
+      -validate		=> "key",
+      -validatecommand	=> \&$validate,
+    )->pack (
+      -side		=> "left",
+      -padx		=> 5,
+      -anchor		=> "e",
+    );
+  } # _createTextField
+
+  #---------------------------------------------------------------------------
+  # _createText (): Creates a multiline text field widget in $parent with a
+  #		    $label and a $value, using the specified $rows and $cols
+  #		    and a $validate procedure.
+  #---------------------------------------------------------------------------
+  sub _createText ($$$$$$) {
+    my ($parent, $label, $value, $rows, $cols, $validate) = @_;
+
+    $parent->Label (
+      -text		=> "$label:",
+      -justify		=> "right",
+      -width		=> 10,
+    )->pack (
+      -side		=> "left",+
+      -anchor		=> "n",
+      -pady		=> 5,
+    );
+
+    $parent->MyText (
+      -foreground	=> $EDIT_FOREGROUND,
+      -background	=> $EDIT_BACKGROUND,
+      -height		=> $rows,
+      -width		=> $cols,
+      -modified		=> \&$validate,
+      -text		=> $value,
+    )->pack (
+      -side		=> "left",
+      -pady		=> 5,
+      -anchor		=> "s",
+    );
+  } # _createText
+
+  #---------------------------------------------------------------------------
+  # _createButton (): Creates a pushbutton widget in $parent with a $label and
+  #		      an $action.
+  #---------------------------------------------------------------------------
+  sub _createButton ($$$) {
+    my ($parent, $label, $action) = @_;
+
+    $parent->Button (
+      -activeforeground	=> $EDIT_FOREGROUND,
+      -activebackground	=> $EDIT_BACKGROUND,
+      -text		=> $label,
+      -width		=> length $label,
+      -command		=> \$action
+    )->pack (
+      -side		=> "left",
+      -padx		=> 5
+    );
+  } # _createButton
+
+  #---------------------------------------------------------------------------
+  # _changeDropDown (): Refreshes the values in the dropdown menu.
+  #---------------------------------------------------------------------------
+  sub _changeDropDown ($@) {
+    my ($dropdown, @values) = @_;
+
+    if ($dropdown) {
+      my $menu = $dropdown->menu;
+
+      if ($menu) {
+	$dropdown->menu->delete (0, "end");
+      } # if
+
+      $dropdown->addOptions (@values);
+    } # if
+  } # _changeDropDown
+
+  #---------------------------------------------------------------------------
+  # _refresh (): Refreshes the application by getting news values from
+  #		 Clearquest. Note a change in one dropdown may change others,
+  #		 so we re-get all of them through this procedure.
+  #---------------------------------------------------------------------------
+  sub _refresh () {
+    my $fieldname;
+
+    $fieldname 		= "project";
+    my %projects	= CQTool::getProjects $CQTool::session;
+    $wor{$fieldname}	= $_projects[0] if !$wor{fieldname};
+    $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
+
+    $fieldname		= "prod_arch1";
+    @_prod_arch1s	= _getChoices $CQTool::entity, $fieldname;
+    $wor{$fieldname}	= $_prod_arch1s[0] if !$wor{$fieldname};
+    $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
+
+    $fieldname		= "prod_arch2";
+    @_prod_arch2s	= _getChoices $CQTool::entity, $fieldname;
+    $wor{$fieldname}	= $_prod_arch2s[0] if !$wor{$fieldname};
+    $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
+
+    $fieldname		= "rclc_name";
+    @_rclcs		= @{$projects{$wor{project}}};
+    $wor{$fieldname}	= $_rclcs[0] if !$wor{$fieldname};
+    $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
+
+    $fieldname		= "engr_target";
+    @_engr_targets	= _getChoices $CQTool::entity, $fieldname;
+    $wor{$fieldname}	= $_engr_targets[0] if !$wor{$fieldname};
+    $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
+
+    $fieldname		= "work_code_name";
+    @_work_codes	= _getChoices $CQTool::entity, $fieldname;
+    $wor{$fieldname}	= $_work_codes[0] if !$wor{$fieldname};
+    $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
+
+    $fieldname		= "work_product_name";
+    @_work_products	= _getChoices $CQTool::entity, $fieldname;
+    $wor{$fieldname}	= $_work_products[0] if !$wor{$fieldname};
+    $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
+
+    _changeDropDown ($_projects,	keys %projects);
+    _changeDropDown ($_rclcs,		@_rclcs);
+    _changeDropDown ($_prod_arch1s,	@_prod_arch1s);
+    _changeDropDown ($_prod_arch2s,	@_prod_arch2s);
+    _changeDropDown ($_engr_targets,	@_engr_targets);
+    _changeDropDown ($_work_codes,	@_work_codes);
+    _changeDropDown ($_work_products,	@_work_products);
+
+    _setSubmitButton ();
+  } # _refresh
+
+  #---------------------------------------------------------------------------
+  # _darken (): Returns a slightly darker color than the passed in color
+  #---------------------------------------------------------------------------
+  sub _darken ($) {
+    my ($color) = @_;
+
+    # Get the RGB values
+    my ($r, $g, $b) = $_createWORUI->rgb($color);
+
+    # Set them to $DARKEN % of their previous values
+    my $DARKEN = .8;
+    my $rhex = sprintf "%x", $r * $DARKEN;
+    my $ghex = sprintf "%x", $g * $DARKEN;
+    my $bhex = sprintf "%x", $b * $DARKEN;
+
+    # Return a color string
+    return "\#$rhex$ghex$bhex";
+  } # _darken
+
+  #---------------------------------------------------------------------------
+  # createWORUI (): This is the main and exported routine that creates and
+  #		    handles the entire Perl/Tk application for creating a
+  #		    WOR.
+  #---------------------------------------------------------------------------
+  sub createWORUI () {
+    $_createWORUI = MainWindow->new;
+
+    $EDIT_FOREGROUND	= $_createWORUI->optionGet ("foreground", "Foreground");
+    $EDIT_BACKGROUND	= _darken ($_createWORUI->optionGet ("background", "Background"));
+
+    $wor{id} = "None" if !$wor{id};
+
+    $_createWORUI->title ("Submit WOR $wor{id}");
+
+    my $frame0 = $_createWORUI->Frame->pack (-pady => 2);
+    my $frame1 = $_createWORUI->Frame->pack;
+    my $frame2 = $_createWORUI->Frame->pack;
+    my $frame3 = $_createWORUI->Frame->pack;
+    my $frame4 = $_createWORUI->Frame->pack;
+
+    _createTextField (
+      $frame1,
+      "Headline",
+      \$wor{headline},
+      100,
+      \&_validateEntry
+    );
+
+    _createText (
+      $frame2,
+      "Description",
+      \$wor{description},
+      24, 100,
+      \&_validateText
+    );
+
+    my %projects = CQTool::getProjects ($CQTool::session);
+    @_projects = keys %projects;
+
+    $_projects = _createDropDown (
+      $frame3,
+      0, 0,
+      "Project",
+      \&_refresh,
+      \$wor{project},
+      @_projects
+    );
+    $_rclcs = _createDropDown (
+      $frame3,
+      0, 3,
+      "Revision Control Life Cycle",
+      \&_refresh,
+      \$wor{rclc_name},
+      @_rclcs
+    );
+
+    $_prod_arch1s = _createDropDown (
+      $frame3,
+      2, 0,
+      "Product Architecture 1",
+      \&_refresh,
+      \$wor{prod_arch1},
+      @_prod_arch1s
+    );
+    $_engr_targets = _createDropDown (
+      $frame3,
+      2, 3,
+      "Engineering Target",
+      \&_refresh,
+      \$wor{engr_target},
+      @_engr_targets
+    );
+
+    $_prod_arch2s = _createDropDown (
+      $frame3,
+      4, 0,
+      "Product Architecture 2",
+      \&_refresh,
+      \$wor{prod_arch2},
+      @_prod_arch2s
+    );
+    $_work_codes = _createDropDown (
+      $frame3,
+      4, 3,
+      "Work Code",
+      \&_refresh,
+      \$wor{work_code_name},
+      @_work_codes
+    );
+
+    $_work_products = _createDropDown (
+      $frame3,
+      6, 0,
+      "Work Product",
+      \&_refresh,
+      \$wor{work_product_name},
+      @_work_products
+    );
+
+    my $fieldname	= "wor_class";
+    @_wor_classes	= _getChoices $CQTool::entity, $fieldname;
+    $wor{$fieldname}	= "Worker";
+    $CQTool::entity->SetFieldValue ($fieldname, $wor{$fieldname});
+
+    $_wor_classes = _createDropDown (
+      $frame3,
+      6, 3,
+      "WOR Class",
+      sub {},
+      \$wor{wor_class},
+      @_wor_classes
+    );
+
+    # Default WOR Class to Worker
+    $_wor_classes->setOption ("Worker");
+
+    $_submit = _createButton ($frame4, "Submit", \&_submit);
+
+    $_submit->configure (
+      -state	=> "disabled",
+    );
+
+    _createButton ($frame4, "Display",	\&_displayValues) if (get_debug);
+    _createButton ($frame4, "About",	\&_helpAbout);
+    _createButton ($frame4, "Exit",	\&_destroyCreateWORUI);
+  } # createWORUI
+
+1;